AW: Doppelte Einträge markieren
04.03.2004 11:14:12
Franz W.
Hallo Andre,
ohne dir viel weiterhelfen zu können, weil ich jetzt vom Gerät weg muss (aber mit VBA gut kannst du es ja vielleicht selber auf deine Bedürfnisse übertragen; wenn nicht hilft dir sicher ein anderer weiter): hier ein Code von Hans:
Sub Vergleich()
Dim iRowA As Integer, iRowB As Integer
Dim iColor As Integer
Dim iRowC As Integer
Dim bln As Boolean, blnColor As Boolean
Worksheets("Daten").Activate
iRowA = 3
iColor = 2
Application.ScreenUpdating = False
Columns("F:G").Interior.ColorIndex = xlNone
With Range(Cells(1, 6), Cells(1, 7)).Interior
.ColorIndex = 5
.Pattern = xlSolid
End With
Do Until IsEmpty(Cells(iRowA, 6))
iRowB = iRowA + 1
Do Until IsEmpty(Cells(iRowB, 6))
If Cells(iRowA, 6) <> Cells(iRowB, 6) Then
bln = True
End If
If bln = False Then
If blnColor = False Then
iColor = iColor + 1
End If
If Cells(iRowB, 6).Interior.ColorIndex = _
xlColorIndexNone Then
If Cells(iRowA, 6).Interior.ColorIndex = _
xlColorIndexNone Then
End If
Range(Cells(iRowA, 6), Cells(iRowB, 7)). _
Interior.ColorIndex = iColor
'###### Folgende Zeile ist nur erforderlich, wenn die zu markierenden Zeilen nicht zusammen hängen
Cells(iRowB, 7).Interior.ColorIndex = iColor
Application.ScreenUpdating = True
' Beep
Cells(iRowA, 6).Select
blnColor = True
End If
End If
iRowB = iRowB + 1
bln = False
Loop
blnColor = False
iRowA = iRowA + 1
Loop
End Sub
Viel Erfolg und Grüße
Franz