|
Da war noch was falsch und unvollständig. Nun wird der Range blockweise markiert und nicht jeder Treffer einzeln.
Sub MehrfachvorkommenMarkieren(Bereich As Range, Spalte As Variant)
Dim objDic As Object
Dim arrSp(), arrDic, i&, j&, tmp$
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) = .Cells(j, Spalte(0)) Then
If InStr(1, tmp, "A" & j, vbTextCompare) = 0 Then
tmp = tmp & ",A" & j + 2
If Len(tmp) > 240 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
End Sub
Gruß Uwe
|