Как пролистать границы в Excel и изменить их цвет?

Question

Я пытаюсь перебрать активные границы в Excel и изменить их цвета на «следующий».

Вот код, который у меня есть:

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

Это работает. Он не меняет вес границ и не добавляет новые границы (только изменяет существующие).

Проблема в том, что когда две ячейки находятся рядом, внешние границы изменяются на «следующий + 1». "color, и внутренние границы изменяются на цвет" следующий + 2 ", поскольку они повторяются два раза.

РЕДАКТИРОВАТЬ: код должен проверить, соответствуют ли существующие цвета границ тем, которые я хочу использовать. Во-вторых, во-первых, цвета должны быть унифицированы, чтобы избежать выделения нескольких рамочных цветов.

Изображение проблемы

Я хочу объединить границы, а затем иметь возможность переключаться между их цветами, независимо от их веса и без добавления новых границ.

Answer 1

Этот код должен делать то, что вы хотите. Он считывает существующий цвет из рамочной ячейки в выделении, определяет, какой следующий цвет установить, и устанавливает все цвета соответствующим образом.

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

Процедура имеет необязательный аргумент, который, если задано значение True, вызывает сброс. Текущая программа устанавливает цвет границы по умолчанию. Оглядываясь назад, идея не так актуальна, потому что вы можете вызвать сброс, выполнив код 4 или меньше раз. Но когда я начинал, это казалось хорошей идеей. Теперь вы можете предпочесть удалить функцию. Самый простой способ - удалить аргумент из объявления, добавить Dim Reset As Boolean к объявлениям переменных и оставить остальное для себя.

Пока у вас есть возможность сброса, используйте посредник для вызова процедуры , Любой из трех вариантов, показанных ниже, будет работать.

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

Вызовите sub CallCycleBorderColors из рабочего листа.

Answer 2

Вы не загружаете изображение u, показывающее cell.border, поэтому я не могу понять, как вы хотите работать.

Я предполагаю, что при выделении цвета границ изначально одинаковы, и они находятся в цвета, которые вы даете. попробуйте это:

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

Примечания:

-Не нужно xlInsideVertical, xlInsideHor Horizontal при циклическом прохождении ячеек.

-Я проведу l oop через типы ребер перед итерацией через каждую клетку

Answer 3

Вот один из подходов - обратите внимание, что я удалил некоторые из ваших перечислений границ - если вы перемещаетесь по каждой ячейке, то, скорее всего, вы можете игнорировать «внешние» границы.

Сначала выполняется цикл, чтобы найти, что нужно изменить , но не устанавливает какие-либо цвета рамки в этом первом l oop. Во втором l oop он обновляется, но не изменяет границу, которая уже была изменена как часть обновлений предыдущей ячейки.

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