|
Hallo Jenny,
Crossposting, ohne darauf hinzuweisen, ist nicht unbedingt die feine englische Art. Aber da ich den Code eh schon geschrieben habe:
Option Explicit
Sub extract()
Dim wsQuelle As Worksheet, wsZiel As Worksheet
Dim loSpalte As Long, loLetzteQuelle As Long, loLetzteZiel As Long
Dim i As Long, loEnde As Long
Application.ScreenUpdating = False
Set wsQuelle = ThisWorkbook.Worksheets("Tabelle2")
Set wsZiel = ThisWorkbook.Worksheets("Tabelle1")
'letzte Spalte wbZiel in Zeile 1 (Überschriften) 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 ersten freien Zelle in der Zielspalte
loLetzteZiel = wsZiel.Cells(wsZiel.Rows.Count, i).End(xlUp).Offset(1, 0).Row
'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(loLetzteZiel, i).PasteSpecial xlPasteValues
End With
'nächster Spalte
Next i
Application.CutCopyMode = False
Set wsQuelle = Nothing: Set wsZiel = Nothing
Application.ScreenUpdating = True
End Sub
Gruß Werner
|