nächsten Wert suchen

Sub test()
Dim rngFindID As Object, ersteAdresse$
Dim zeilen_max As Long, i As Long
Dim Identifier As String
Dim sheetDB As Worksheet
Dim sheetImp As Worksheet
Dim rangeImpD As Range
Dim firstAddress As String
Set sheetDB = Worksheets("Datenbasis")
Set sheetImp = Worksheets("imported")
Set rangeImpD = sheetImp.Columns(4)
zeilen_max = sheetDB.Cells(65536, 2).End(xlUp).Row
For i = 8 To zeilen_max
Identifier = sheetDB.Cells(i, 2)
If Identifier <> "" Then
With Worksheets("imported").Range("D:D")
'erste Verknüpfung finden
Set rngFindID = .Find(Identifier)
If Not rngFindID Is Nothing Then
ersteAdresse = rngFindID.Address
sheetDB.Cells(i, 8).ClearContents
sheetDB.Cells(i, 8).Interior.ColorIndex = 37
sheetDB.Cells(i, 8).Value = rngFindID.Offset(0, -2)
End If
'weitere Verknüpfungen finden
Do
Set rngFindID = .FindNext(rngFindID)
If rngFindID.Address = ersteAdresse Then Exit Do
If Not rngFindID Is Nothing Then
sheetDB.Cells(i, 9).ClearContents
sheetDB.Cells(i, 9).Interior.ColorIndex = 37
sheetDB.Cells(i, 9).Value = rngFindID.Offset(0, -2)
End If
Loop While Not rngFindID Is Nothing And rngFindID.Address <> ersteAdresse
End With
End If
Next i
End Sub