Set wb = ThisWorkbook
Set ws = wb.Sheets("Preis")
lSpalte = 1
strFile = Application.GetOpenFilename
Set wbZwei = Workbooks.Open(Filename:=strFile)
Set wsZwei = wbZwei.Sheets("NEU")
wsZwei.Select
Application.ScreenUpdating = False
For i = 10 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
sWert = ws.Cells(i, lSpalte).Value
If Trim(sWert) <> "" Then
On Error Resume Next
Set rngBereich = wsZwei.Cells.Find(What:=sWert, LookIn:=xlValues, LookAt:=xlPart)
On Error GoTo 0
If Not rngBereich Is Nothing Then
ws.Cells(i, lSpalte + 4).Font.ColorIndex = 3
ws.Cells(i, lSpalte + 5).Value = "JA"
ws.Cells(i, lSpalte + 5).Font.ColorIndex = 1
Else
ws.Cells(i, lSpalte + 5).Value = "NEIN"
End If
End If
Next i
Application.ScreenUpdating = True
Cancel = True
End Sub