Sub DoIt()
Dim ShS As Excel.Worksheet, ShF As Excel.Worksheet
Dim rng As Range, arr() As Variant, x As Long, c As Range
Set ShS = ThisWorkbook.Sheets("Tabelle1")
Set ShF = ThisWorkbook.Sheets("Tabelle2")
With ShS
Set rng = Range(.Cells(1), .Cells(.Rows.Count, 1).End(xlUp))
rng.Interior.ColorIndex = -4142
arr = rng.Resize(, 2).Value
For x = LBound(arr, 1) To UBound(arr, 1)
Set c = ShF.Cells.Find(arr(x, 1), , xlValues, xlPart)
If Not c Is Nothing Then
arr(x, 2) = True
Else
arr(x, 2) = False
End If
Next x
For x = LBound(arr, 1) To UBound(arr, 1)
If arr(x, 2) Then rng.Cells(x).Interior.ColorIndex = 3
Next x
End With
End Sub
|