Der Prozess, von dem Sie sprechen, nennt sich "Duplicate Banding". Ein Paar Scripting.Dictionary Objekte sollten dies problemlos erledigen.
Sub colorDuplicateColor2()
Dim d As Long, dODDs As Object, dEVNs As Object, vTMPs As Variant
Dim bOE As Boolean
Set dODDs = CreateObject("Scripting.Dictionary")
Set dEVNs = CreateObject("Scripting.Dictionary")
dODDs.CompareMode = vbTextCompare
dEVNs.CompareMode = vbTextCompare
With Worksheets("Sheet7")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp))
With .Columns(1)
.Cells.Interior.Pattern = xlNone
End With
With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
vTMPs = .Value2
End With
For d = LBound(vTMPs, 1) To UBound(vTMPs, 1)
'the dictionary Items have to be strings to be used as filter criteria
If Not (dODDs.exists(vTMPs(d, 1)) Or dEVNs.exists(vTMPs(d, 1))) Then
If bOE Then
dODDs.Item(vTMPs(d, 1)) = CStr(vTMPs(d, 1))
Else
dEVNs.Item(vTMPs(d, 1)) = CStr(vTMPs(d, 1))
End If
bOE = Not bOE
End If
Next d
With .Columns(1)
.AutoFilter Field:=1, Criteria1:=dODDs.Items, Operator:=xlFilterValues
.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(210, 210, 210)
'use this to band the entire row
'.SpecialCells(xlCellTypeVisible).EntireRow.Interior.Color = RGB(210, 210, 210)
'use this to band the row within the UsedRange
'Intersect(.Parent.UsedRange, .SpecialCells(xlCellTypeVisible).EntireRow).Interior.Color = RGB(210, 210, 210)
.AutoFilter
.AutoFilter Field:=1, Criteria1:=dEVNs.Items, Operator:=xlFilterValues
.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(255, 200, 200)
.Cells(1).EntireRow.Interior.Pattern = xlNone
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
dODDs.RemoveAll: Set dODDs = Nothing
dEVNs.RemoveAll: Set dEVNs = Nothing
Erase vTMPs
End Sub
Die Daten müssen natürlich nach der Spalte mit den doppelten Kriterien sortiert werden.
Dieser Prozess könnte leicht für vollständige Reihen- oder Reihen-innerhalb-Datenblock-Banderstellung angepasst werden.
