问题
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
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.
回答1:
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.
回答2:
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
回答3:
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
来源：https://stackoverflow.com/questions/60582649/how-to-cycle-through-borders-in-excel-and-change-their-color