podświetlanie zduplikowanych wierszy w programie Excel za pomocą makra VBA

Mam macierz, która zawiera różne / te same wartości w pierwszej kolumnie i różne wartości w pierwszym rzędzie.

Chciałbym porównać wszystkie wiersze i wyróżnić zduplikowane wiersze. Dla każdego wiersza powinien sprawdzić kombinację wartości „+”, „-” i „/” oraz wyróżnić zduplikowane pary wierszy (potrójne itp.) W różnych kolorach (inny kolor dla każdej zduplikowanej pary)

Należy również założyć, że trzy wiersze jak poniżej są duplikatami. Will Przyjmie wartości „/” jako „+” i „-” i podświetli te wiersze również jako duplikaty.

Oto przykład wyniku makra, który chciałbym mieć (wiersze w tym samym kolorze są duplikatami);

EDYCJA: x4 i x7 są również duplikatami z x1 i x2. I są też inne duplikaty, których nie pokolorowałem. Właśnie pokolorowałem niektóre duplikaty, aby wyjaśnić mój problem.

Chciałbym przekształcić twoje pasujące reguły w następujący sposób (mam nadzieję, że mam rację):

• + pasuje do wszystkiego w klasie [+/]
• - pasuje do wszystkiego w klasie [-/]
• / pasuje do wszystkiego w klasie [-+/]

Biorąc to pod uwagę, chodzi o utworzenie wzorca z konkatenacji łańcucha, który będzie działał jako pasujący wzorzec. Można to zrobić za pomocą wyrażeń regularnych, ale VBA ma metodę Like, która będzie działać równie dobrze, być może szybciej.

Konfigurujemy wszystko, najpierw wstawiając moduł klasy i zmieniając jego nazwę na cRowString

Moduł klasy

Option Explicit
Private pRow As Long
Private pColA As String
Private pConcatString As String
Private pPattern As String

Public Property Get Row() As Long
    Row = pRow
End Property
Public Property Let Row(Value As Long)
    pRow = Value
End Property

Public Property Get ColA() As String
    ColA = pColA
End Property
Public Property Let ColA(Value As String)
    pColA = Value
End Property

Public Property Get ConcatString() As String
    ConcatString = pConcatString
End Property
Public Property Let ConcatString(Value As String)
    pConcatString = Value
End Property

Public Property Get Pattern() As String
    Pattern = pPattern
End Property
Public Property Let Pattern(Value As String)
    pPattern = Value
End Property

Następnie wprowadź ten zwykły moduł

Option Explicit
Sub HilightDuplicateRows()
    Dim vData As Variant, lColors() As Long, V As Variant
    Dim colDups As Collection
    Dim R As Range
    Dim cR As cRowString, colRows As Collection
    Dim arrColors
    Dim S1 As String, S2 As String
    Dim I As Long, J As Long, K1 As Long, K2 As Long, L As Long

arrColors = VBA.Array(vbRed, vbCyan, vbYellow, vbGreen)

'get original range and load data into array
Set R = Range("a1", Cells(Rows.Count, "A").End(xlUp))
I = Cells(1, Columns.Count).End(xlToLeft).Column
Set R = R.Resize(columnsize:=I)

vData = R

'Iterate through and create patterns, collect them
Set colRows = New Collection
For I = 2 To UBound(vData, 1)
    S1 = ""
    S2 = ""
    For J = 2 To UBound(vData, 2)
        S1 = S1 & vData(I, J)
        Select Case vData(I, J)
            Case "+"
                S2 = S2 & "[+/]"
            Case "-"
                S2 = S2 & "[-/]"
            Case "/"
                S2 = S2 & "[-+/]"
        End Select
    Next J
    Set cR = New cRowString
    With cR
        .Row = I
        .ColA = vData(I, 1)
        .ConcatString = S1
        .Pattern = S2
    End With
    colRows.Add cR
Next I

'Check for duplicate pairs
Set colDups = New Collection
For I = 1 To colRows.Count - 1
    For J = I + 1 To colRows.Count
        If colRows(I).ConcatString Like colRows(J).Pattern Then
            colDups.Add CStr(colRows(I).Row & "," & colRows(J).Row)
        End If
    Next J
Next I

'Color the rows
ReDim lColors(1 To UBound(vData, 1))
J = 0
For I = 1 To colDups.Count
    V = Split(colDups(I), ",")
    If IsArray(V) Then
        Select Case lColors(V(0))
            Case 0
                J = J + 1
                K1 = J Mod (UBound(arrColors) + 1)
                lColors(V(0)) = arrColors(K1)
                lColors(V(1)) = arrColors(K1)
            Case Else
                lColors(V(1)) = lColors(V(0))
        End Select
    Else
        lColors(V) = xlAutomatic
    End If
Next I

R.Interior.Color = xlAutomatic
For I = 1 To R.Rows.Count
If lColors(I) = 0 Then
    R.Rows(I).Interior.Color = xlAutomatic
Else
    R.Rows(I).Interior.Color = lColors(I)
End If
Next I

End Sub

Wybierz aktywny arkusz i uruchom makro

Być może połącz zawartość (col-F), policz dopasowania (col-G), a następnie zastosuj format warunkowy na podstawie liczby zliczeń.

Takie podejście oznacza, że ​​dwa zestawy wierszy o tej samej liczbie sztuk będą miały ten sam kolor.