Excel 2010 Makro: Intelligentes Kopieren von Daten in 2 Tabellenblättern

Sub SearchAndCopy()
    Dim ws1 As Worksheet, ws2 As Worksheet, f As Range, cell As Range, rngWert As Range, currentTarget As Range, rngContent As Range
    'Tabellenblätter referenzieren  
    Set ws1 = Worksheets(1)
    Set ws2 = Worksheets(2)
    ' Für jede Überschrift in Tabelle2  
    For Each cell In ws2.Range("A1", ws2.Cells(1, Columns.Count).End(xlToLeft))  
        ' Für jede Überschrift im Bereich der Überschriften in Tabelle1  
        With ws1.Range("A1", ws1.Cells(1, Columns.Count).End(xlToLeft))  
            'Suche die aktuelle Überschrift in Tabelle2 im Bereich von Tabelle1  
            Set f = .Find(cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            'Nur wenn die Überschrift gefunden wurde ...  
            If Not f Is Nothing Then
                ' belegten Bereich unter der jeweiligen Überschrift ermitteln  
                Set rngContent = ws1.Range(f.Offset(1, 0), ws1.Cells(Rows.Count, f.Column).End(xlUp))
                ' für jede Zelle im belegten Bereich ...  
                For Each rngWert In rngContent
                    ' Bereich in Tabelle2 eine Zeile nach unten verschieben  
                    Set currentTarget = cell.Offset(1, 0)
                    ' Bereich solange nach unten verschieben bis eine nicht leere Zelle kommt  
                    While currentTarget.Value <> ""  
                        Set currentTarget = currentTarget.Offset(1, 0)
                    Wend
                    'Schreibe den Inhalt in die Zielzelle  
                    currentTarget.Value = rngWert.Value
                Next
            End If
        End With
    Next
End Sub