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")
loEnde = wsZiel.Cells(1, wsZiel.Columns.Count).End(xlToLeft).Column
For i = 1 To loEnde
With wsQuelle
loSpalte = Application.Match(wsZiel.Cells(1, i), .Rows(1), 0)
loLetzteZiel = wsZiel.Cells(wsZiel.Rows.Count, i).End(xlUp).Offset(1, 0).Row
loLetzteQuelle = .Cells(.Rows.Count, loSpalte).End(xlUp).Row
.Range(.Cells(2, loSpalte), .Cells(loLetzteQuelle, loSpalte)).Copy
wsZiel.Cells(loLetzteZiel, i).PasteSpecial xlPasteValues
End With
Next i
Application.CutCopyMode = False
Set wsQuelle = Nothing: Set wsZiel = Nothing
Application.ScreenUpdating = True
End Sub