How to cycle through borders in Excel and change their color?

1
votes

I am trying to cycle through active borders in Excel and to change their colors to "next one".

Here is the code I have:

Dim Color1 As Variant
Dim Color2 As Variant
Dim Color3 As Variant
Dim Color4 As Variant
Dim Color5 As Variant

Color_default = RGB(0, 0, 0)
Color1 = RGB(255, 0, 0)
Color2 = RGB(0, 255, 0)
Color3 = RGB(0, 0, 255)
Color4 = RGB(222, 111, 155)
Color5 = RGB(111, 111, 111)

Dim cell As Range
Dim positions As Variant
Dim i As Integer

positions = Array(xlDiagonalDown, xlDiagonalDown, xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)

For Each cell In Selection
    For i = LBound(positions) To UBound(positions)
        If cell.BORDERS(positions(i)).LineStyle <> xlNone Then
            If cell.BORDERS(positions(i)).Color = Color_default Then
                cell.BORDERS(positions(i)).Color = Color1
            ElseIf cell.BORDERS(positions(i)).Color = Color1 Then
                cell.BORDERS(positions(i)).Color = Color2
            ElseIf cell.BORDERS(positions(i)).Color = Color2 Then
                cell.BORDERS(positions(i)).Color = Color3
            ElseIf cell.BORDERS(positions(i)).Color = Color3 Then
                cell.BORDERS(positions(i)).Color = Color4
            ElseIf cell.BORDERS(positions(i)).Color = Color4 Then
                cell.BORDERS(positions(i)).Color = Color5
            Else
                cell.BORDERS(positions(i)).Color = Color_default
            End If
        End If
    Next i
Next cell

It works. It does not change the weight of the borders and it does not add new borders (only changes the existing ones).

The issue is that when two cells are nearby, the outer borders are changes to "next+1" color, and the inner borders are changed to "next+2" color, as they are looped through two times.

EDIT: The code should check if the existing border colors are the ones I want to use. Secondly, the colors should be unified first, to avoid multiple border colors within selection.

A picture of the problem
enter image description here

I want to unify the borders and then be able to cycle through their colors, regardless what their weight is and without adding NEW borders.

3
excelvbaloopsborder
Do you need to have different cells with different border colors, or should they all be the same? – Tim Williams
you could put a variable in the code that registers the cell address the first time it's changed, so on the 2nd loop it won't change it again. – Scott Holtzman
They all should be the same, that's why I have this issue. It works, but some of the "inner" borders are cycled through more than once, and their color is changed two times, instead of once... This issue is what I cannot work through. When two 5 cells are together and I run this macro, almost all borders are colored in black or red, while some of the inner borders are in green (which is a next step). I hope you understand my idea :) – Rafał Kowalski
@ScottHoltzman - How could I do that? I have been thinking about something similar but I am too newbie to actually do it :) Any additional hints? – Rafał Kowalski

3 Answers

1
votes

This code should do what you want. It reads the existing color from a framed cell within the selection, determines which is the next color to set and sets all colours accordingly.

Sub CycleBorderColors(Optional ByVal Reset As Boolean)

    Dim BorderColor As Variant
    Dim BorderPos As Variant
    Dim CurrentColor As Long
    Dim ColorIndex As Long
    Dim Cell As Range
    Dim i As Integer


    BorderPos = Array(xlDiagonalDown, xlDiagonalUp, xlEdgeLeft, xlEdgeTop, _
                      xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
    BorderColor = Array(RGB(0, 0, 0), RGB(255, 0, 0), RGB(0, 255, 0), _
                        RGB(222, 111, 155), RGB(111, 111, 111))

    If Reset Then
        ColorIndex = Reset
    Else
        CurrentColor = xlNone
        ' read the border color of the first selected cell with a border
        For Each Cell In Selection.Cells
            For i = LBound(BorderPos) To UBound(BorderPos)
                With Cell
                    If .Borders(BorderPos(i)).LineStyle <> xlNone Then
                        CurrentColor = .Borders(BorderPos(i)).Color
                        Exit For
                    End If
                End With
            Next i
            If CurrentColor <> xlNone Then Exit For
        Next Cell
        If CurrentColor = xlNone Then
            MsgBox "The selection includes no cells with borders.", _
                   vbInformation, "Inapplicable selection"
            Exit Sub
        End If

        For ColorIndex = UBound(BorderColor) To 0 Step -1
            If BorderColor(ColorIndex) = CurrentColor Then Exit For
        Next ColorIndex
        ' ColorIndex will be -1 if not found
    End If
    ColorIndex = ColorIndex + 1                 ' set next color
    If ColorIndex > UBound(BorderColor) Then ColorIndex = 0

    For Each Cell In Selection
        For i = LBound(BorderPos) To UBound(BorderPos)
            If Cell.Borders(BorderPos(i)).LineStyle <> xlNone Then
                Cell.Borders(BorderPos(i)).Color = BorderColor(ColorIndex)
            End If
        Next i
    Next Cell
End Sub

The procedure has an optional argument which, if set to True, causes a reset. The current program sets the border color to default. In hindsight the idea isn't so hot because you could cause a reset by running the code 4 or fewer times. But when I started it seemed like a good idea. Now you may prefer to remove the feature. The easiest way would be to remove the argument from the declaration, add Dim Reset As Boolean to the variable declarations and leave the rest to itself.

While you do have the the option to reset use an intermediary to call the procedure. Any of the three variants shown below will work.

Sub CallCycleBorderColors()
    CycleBorderColors
  ' CycleBorderColors True
  ' CycleBorderColors False
End Sub

Call the sub CallCycleBorderColors from the worksheet.

0
votes

Here's one approach - note I removed some of your border enums - if you're cycling over each cell then you can likely ignore the "outer" borders.

It first loops to find what needs to change, but doesn't set any border colors in that first loop. In the second loop it updates, but won't change a border that's already been changed as part of a previous cell's updates.

Sub BorderColor()

    Dim cell As Range
    Dim positions As Variant
    Dim i As Long, clrNow As Long, clrNext As Long, Pass As Long
    Dim col As New Collection, arr

    positions = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)

    For Each cell In Range("C4:F11").Cells
        For i = LBound(positions) To UBound(positions)
            If cell.Borders(positions(i)).LineStyle <> xlNone Then
                With cell.Borders(positions(i))
                    'store the cell, border position, current color and new color
                    col.Add Array(cell, positions(i), .Color, NextColor(.Color))
                End With
            End If
        Next i
    Next cell
    'now loop and set the new color if needed
    For Each arr In col
        Set cell = arr(0)
        With cell.Borders(arr(1))
            'only change the color if it hasn't already been changed
            If .Color = arr(2) Then .Color = arr(3)
        End With
    Next


End Sub

'get next color (cycles through array)
Function NextColor(currentColor As Long) As Long
    Dim arr, i As Long, rv As Long
    arr = Array(RGB(0, 0, 0), RGB(255, 0, 0), _
                RGB(0, 255, 0), RGB(0, 0, 255), _
                RGB(222, 111, 155), RGB(111, 111, 111))
    rv = -1
    For i = LBound(arr) To UBound(arr)
        If currentColor = arr(i) Then
            If i < UBound(arr) Then
                rv = arr(i + 1)
            Else
                rv = arr(LBound(arr))
            End If
            Exit For
        End If
    Next
    If rv = -1 Then rv = RGB(0, 0, 0) 'default next
    NextColor = rv
End Function
0
votes

You don't upload u's image showing cell.border so I can't figure out how you want to work.

I assume that in selection, the border colors are initially the same and they are in the colors you give. try this:

Sub Test()
    Dim color As Variant, cell As Range
    Dim arr_Color, Arr_Border, Index, item
    'black-> red -> green -> blue -> pink-> Brown-> black
    arr_Color = Array(RGB(0, 0, 0), RGB(255, 0, 0), RGB(0, 255, 0), _
                      RGB(0, 0, 255), RGB(222, 111, 155), RGB(111, 111, 111), RGB(0, 0, 0))
    Arr_Border = Array(xlEdgeLeft, xlEdgeTop, xlEdgeRight, xlEdgeBottom)
    Dim origin As Range: Set origin = selection
    For Each item In Arr_Border
            If item = xlEdgeRight Then
                Set selection = selection.Resize(selection.Rows.Count, 1).Offset(0, selection.Columns.Count - 1)
            End If
            If item = xlEdgeBottom Then
                Set selection = origin.Resize(1, origin.Columns.Count).Offset(origin.Rows.Count - 1, 0)
            End If
        For Each cell In selection.Cells
        color = cell.Borders(item).color
        Index = Application.Match(color, arr_Color, 0)
            If Not (IsError(Index)) Then
            color = arr_Color(Index)
                If cell.Borders(item).LineStyle <> xlLineStyleNone Then
                     cell.Borders(item).color = color
                End If
            End If
        Next cell

    Next item
End Sub

Notes:

-Unnecessary xlInsideVertical, xlInsideHorizontal when looping through the cells.

-I will loop through the edge types before iterating through each cell