Hallo,

eventuell hilft dieser Code weiter?

Option Explicit

Sub CopyData()
    Dim wshSrc As Worksheet
    Dim wshDest As Worksheet
    
    Dim rngSrc As Range, rngDest As Range, rngDestField As Range
    Dim rngSrcCol As Range
    Dim rngNewData As Range
    
    Set wshSrc = ActiveWorkbook.Worksheets(1)
    Set wshDest = ActiveWorkbook.Worksheets(2)
    
    For Each rngSrc In wshSrc.UsedRange.Rows
        If rngSrc.Row > 1 Then
            ' freie Zeile in Destination finden
            For Each rngDest In wshDest.UsedRange.Rows
                If IsEmpty(rngDest) Then
                    Exit For
                End If
            Next
            If rngDest Is Nothing Then
                Set rngDest = Intersect(wshDest.UsedRange.SpecialCells(xlCellTypeLastCell).EntireRow, wshDest.UsedRange).Offset(1)
            End If
            If Not rngDest Is Nothing Then
                For Each rngSrcCol In wshSrc.UsedRange.Columns
                    ' Titel Finden in Destination
                    For Each rngDestField In wshDest.UsedRange.Columns
                        If rngDestField.Cells(1, 1).Value = rngSrcCol.Cells(1, 1).Value Then
                            ' gefunden
                            Set rngNewData = Intersect(rngDestField.EntireColumn, rngDest)
                            ' Neuen Wert eintragen
                            rngNewData.Formula = Intersect(rngSrcCol, rngSrc).Value
                            Exit For
                        End If
                    Next
                Next
            End If
        End If
    Next
End Sub

Kurze Erläuterung:

Der Code liest Zeile für Zeile in Tabeklle 1 ein und sucht anschließend in Tabelle 2 eine leere Zeile. Im zweiten Schritt wird der Inhalt aus Tabelle 1 in Tabelle 2 Zellenweise übertragen, sofern die Feldbezeichnung vorhanden ist.

LG, BigBen