Hallo Thomas,

die Zeile mit Application.Match war falsch. Du hast ,Rows(1) muss aber .Rows(1) lauten.

Dann gibst du als Zieladresse die Zelle A2 an. Da würdest du dir die Daten im Zielblatt ja immer wieder überschreiben.

Und das ganze dann 30 mal zu schreiben ist auch Quatsch. Schreib doch deine 30 Suchbegriffe im Zielblatt in Spalte B, ab B1. Im Code dann in einer Schleife über die 30 Suchbegriffe.

So nach diesem Muster. Ist aber ungetestet. Versuch es mal mit Sicherheitskopien deiner Arbeitsdateien.

Sub extract()
wbQuelle As Workbook, wbZiel As Workbook
Dim loSpalte As Long, loLetzteQuelle As Long, loLetzteZiel As Long
Dim i As Long, loEnde As Long, A As Integer
 
A = MsgBox("Overwrite existing data with new data?", vbYesNo + vbQuestion, "Import")
 
If A = vbYes Then
    Application.ScreenUpdating = False
    Set wbQuelle = Workbooks.Open("C:\Users\Dateipfad\Datei.xlsx")
    Set wbZiel = ThisWorkbook
    wbZiel.Sheets("data").Rows("2:10000").Delete
    'letzter Suchbegriff wbZiel Spalte B ermitteln
    loEnde = wbZiel.Sheets("data").Cells(wbZiel.Sheets("data").Rows.Count, 2).End(xlUp).Row
    
    'Schleife von Zeile 1 bis Letzter Suchbegriff
    For i = 1 To loEnde
        With wbQuelle.Sheets("source")
            'ermitteln der Spalte im Quellblatt
            loSpalte = Application.Match(wbZiel.Sheets("data").Cells(i, 2), .Rows(1), 0)
            'ermitteln der letzten belegten Zeile im Quellblatt
            loLetzteQuelle = .Cells(.Rows.Count, loSpalte).End(xlUp).Row
            'ermitteln der letzten belegten Zeile im Zielblatt
            loLetzteZiel = wbZiel.Sheets("data").Cells(wbZiel.Sheets("data").Rows.Count, 1).End(xlUp).Row
            'Quelle Zeile 2 ermittelte Spalte bis letzte belegte Zeile ermittelte Spalte kopieren
            .Range(.Cells(2, loSpalte), .Cells(loLetzteQuelle, loSpalte)).Copy
            'im Zielblatt ermittelte letzte belegte Zeile +1 einfügen
            wbZiel.Sheets("data").Cells(loLetzteZiel + 1, 1).PasteSpecial xlPasteValues
        End With
    'nächster Suchbegriff
    Next i
     
    wbQuelle.Close SaveChanges:=False
    wbZiel.Sheets("data").Cells(1, 1).Select
    wbZiel.Sheets("summary").Select
    Application.ScreenUpdating = True
End If
 
End Sub

Gruß Werner