|
letzte Änderung und nun ohne unnötigen Laufzeitverlust. Die Leserei der Vergleichszelle im Range war die Tempobremse.
Sub MehrfachvorkommenMarkieren(Bereich As Range, Spalte As Variant)
Dim objDic As Object
Dim arrSp(), arrDic, i&, j&, tmp$
Application.ScreenUpdating = False
Set objDic = CreateObject("Scripting.Dictionary")
Bereich.Parent.Cells.Interior.ColorIndex = xlColorIndexNone
arrSp = Bereich.Columns(Spalte(0)).Value
For i = 2 To UBound(arrSp)
objDic(arrSp(i, 1)) = 0
Next i
arrDic = objDic.keys
With Bereich
For i = 0 To UBound(arrDic)
If WorksheetFunction.CountIf(.Columns(Spalte(0)), arrDic(i)) > 1 Then
For j = 2 To .Rows.Count
If arrDic(i) = arrSp(j, 1) Then
If InStr(1, tmp, "A" & j, vbTextCompare) = 0 Then
tmp = tmp & ",A" & j + 2
If Len(tmp) > 248 Then
Intersect(Bereich, Tabelle1.Range(Mid(tmp, 2)).EntireRow).Interior.ColorIndex = 4
tmp = ""
End If
End If
End If
Next j
End If
Next i
If tmp <> "" Then Intersect(Bereich, Tabelle1.Range(Mid(tmp, 2)).EntireRow).Interior.ColorIndex = 4
End With
Application.ScreenUpdating = True
End Sub
Gruß Uwe
|