|
Hallo Katrin!
Hier mal eine Version. Ist noch ungetestet, da ich noch nichtzum Nachstellen der Datei kam.
Ich such in Tabelle 2 in Spalte 9. Bei deinem Beispiel oben sind die Daten aber in Spalte 8. HOffe das war nur ein Versehen.
Ich füge nach der Suchzeile immer eine Zeile ein und kopiere dort die Daten rein.
Probiere mal, ob es so wie gewünscht klappt.
Viele Grüße
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) 'da wo alles rein soll
Set zwei = Worksheets(2) 'da wo gesucht wird
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
|