Comment parcourir les bordures dans Excel et changer leur couleur?

Voici une approche - notez que j'ai supprimé certaines de vos énumérations de bordures - si vous parcourez chaque cellule, vous pouvez probablement ignorer les bordures "extérieures".

Il effectue d'abord une boucle pour trouver ce qui doit changer, mais ne le fait pas ne définissez aucune couleur de bordure dans cette première boucle. Dans la deuxième boucle, il met à jour, mais ne change pas une bordure qui a déjà été modifiée dans le cadre des mises à jour d'une cellule précédente.

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

Ce code doit faire ce que vous voulez. Il lit la couleur existante à partir d'une cellule encadrée dans la sélection, détermine quelle est la prochaine couleur à définir et définit toutes les couleurs en conséquence.

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

La procédure a un argument facultatif qui, s'il est défini sur True , provoque une réinitialisation. Le programme actuel définit la couleur de la bordure par défaut. Avec le recul, l'idée n'est pas si chaude car vous pourriez provoquer une réinitialisation en exécutant le code 4 fois ou moins. Mais quand j'ai commencé, cela m'a semblé une bonne idée. Maintenant, vous préférerez peut-être supprimer la fonctionnalité. Le moyen le plus simple serait de supprimer l'argument de la déclaration, d'ajouter Dim Reset As Boolean aux déclarations de variables et de laisser le reste à lui-même.

Tant que vous avez l'option pour réinitialiser, utilisez un intermédiaire pour appeler la procédure. Chacune des trois variantes ci-dessous fonctionnera.

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

Appelez le sous CallCycleBorderColors à partir de la feuille de calcul.

Vous ne téléchargez pas l'image de u montrant cell.border donc je ne peux pas comprendre comment vous voulez travailler.

Je suppose que dans la sélection, les couleurs de la bordure sont initialement les mêmes et elles sont dans les couleurs que vous donner. essayez ceci:

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:

-Inutile xlInsideVertical, xlInsideHorizontal lors de la boucle à travers les cellules.

-Je vais parcourir les types d'arêtes avant de parcourir chaque cellule