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
|