Hallo

versuch das mal

Option Explicit

Sub Zusammenfügen()
    Dim TB1 As Worksheet, TB2 As Worksheet, i As Integer, LR1 As Integer
    Dim S1 As Integer, Off As Integer, LC2 As Integer, Zeile As Integer
    Dim KuNu As Integer, LaufNr As Integer, j As Integer, ÜB
   
    Set TB1 = Sheets("Daten")
    Set TB2 = Sheets("Ausgabe")
   
    S1 = 3 'Artikelnummern ab Spalte C
    Off = 2 'Anzahl der Datenspalten
    LaufNr = 1
    
    'reset
    TB2.UsedRange.Clear
    
    With TB1
        LR1 = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
   
        For i = 2 To LR1
            KuNu = .Cells(i, 1)
            If WorksheetFunction.CountIf(TB2.Columns(1), KuNu) > 0 Then
                Zeile = WorksheetFunction.Match(KuNu, TB2.Columns(1), 0) ' Zeile mit Kunden
                LC2 = TB2.Cells(Zeile, TB2.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile
   
                'Daten kopieren
                .Cells(i, S1).Resize(1, Off).Copy TB2.Cells(Zeile, LC2 + 1)
                
            Else
                Zeile = TB2.Cells(TB2.Rows.Count, "A").End(xlUp).Row + 1
                
                'Daten kopieren
                .Rows(i).Copy TB2.Rows(Zeile)
            
            End If
           
        Next
        
        'Überschriften
        .Rows(1).Copy TB2.Rows(1)
        
        LC2 = TB2.Cells.SpecialCells(xlCellTypeLastCell).Column 'Letzte Spalte des gesamten Blattes
        
        'Bezeichnungen
        ÜB = WorksheetFunction.Transpose(TB2.Cells(1, S1).Resize(1, Off))
        
        For i = S1 To LC2 Step 2
            'hochzählen
            For j = 1 To Off
                TB2.Cells(1, i + j - 1) = ÜB(j, 1) & "_" & LaufNr
            Next
            LaufNr = LaufNr + 1
        Next
        
    End With
   
End Sub

LG UweD