Hallo Thomas,

da bisher keine Antwort hier mal das Makro.

Suchbegriffe stehen im Zielblatt in Zeile 1 von A1 bis A??

Daten werden Spaltenweise im Zielblatt eingefügt, A2, B2, C2.....

Option Explicit

Sub extract()
Dim wbQuelle As Workbook
Dim wsQuelle As Worksheet, wsZiel As Worksheet
Dim loSpalte As Long, loLetzteQuelle 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 wsQuelle = wbQuelle.Worksheets("source")
    Set wsZiel = ThisWorkbook.Worksheets("data")
    
    If wsZiel.UsedRange.Rows.Count > 1 Then
        'Daten im Zielblatt leeren
        wsZiel.UsedRange.Offset(1, 0).Resize(wsZiel.UsedRange.Rows.Count - 1).ClearContents
    End If
    'letzter Suchbegriff wbZiel Spalte B ermitteln
    loEnde = wsZiel.Cells(1, wsZiel.Columns.Count).End(xlToLeft).Column

    'Schleife von Zeile 1 bis Letzter Suchbegriff
    For i = 1 To loEnde
        With wsQuelle
            'ermitteln der Spalte im Quellblatt
            loSpalte = Application.Match(wsZiel.Cells(1, i), .Rows(1), 0)
            'ermitteln der letzten belegten Zeile im Quellblatt
            loLetzteQuelle = .Cells(.Rows.Count, loSpalte).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 in ermittelter Spalte eintragen, nur Werte
            wsZiel.Cells(2, i).PasteSpecial xlPasteValues
        End With
    'nächster Suchbegriff
    Next i

    Application.CutCopyMode = False
    wbQuelle.Close SaveChanges:=False
    wsZiel.Cells(1, 1).Select
    ThisWorkbook.Sheets("summary").Select
    Set wbQuelle = Nothing: Set wsQuelle = Nothing: Set wsZiel = Nothing
    Application.ScreenUpdating = True
End If
  
End Sub

Gruß Werner