Option Explicit
Sub Daten_übernehmen()
Dim i As Long
Dim j As Long
Dim eins As Object
Dim zwei As Object
Dim anzahl As Long
Dim zeile As Long
Dim ende As Long
Dim ende2 As Long
Dim suche
Application.ScreenUpdating = False
Set eins = Worksheets(1)
Set zwei = Worksheets(2)
ende = eins.Cells(Rows.Count, 3).End(xlUp).Row
For i = ende To 1 Step -1
suche = eins.Cells(i, 3)
If suche <> "" Then
anzahl = Application.WorksheetFunction.CountIf(zwei.Columns(9), suche)
If anzahl > 0 Then
zeile = Application.WorksheetFunction.Match(suche, zwei.Columns(9), 0)
ende2 = zwei.Cells(Rows.Count, 9).End(xlUp).Row
For j = 1 To anzahl
eins.Rows(i + 1).Insert shift:=xlDown
zwei.Rows(zeile).Copy eins.Rows(i + 1)
zeile = zeile + Application.WorksheetFunction.Match(suche, zwei.Range(zwei.Cells(zeile + 1, 9), zwei.Cells(ende2, 9)), 0)
Next j
End If
End If
Next i
Set eins = Nothing
Set zwei = Nothing
Application.ScreenUpdating = True
End Sub