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
Off = 2
LaufNr = 1
TB2.UsedRange.Clear
With TB1
LR1 = .Cells(.Rows.Count, "A").End(xlUp).Row
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)
LC2 = TB2.Cells(Zeile, TB2.Columns.Count).End(xlToLeft).Column
.Cells(i, S1).Resize(1, Off).Copy TB2.Cells(Zeile, LC2 + 1)
Else
Zeile = TB2.Cells(TB2.Rows.Count, "A").End(xlUp).Row + 1
.Rows(i).Copy TB2.Rows(Zeile)
End If
Next
.Rows(1).Copy TB2.Rows(1)
LC2 = TB2.Cells.SpecialCells(xlCellTypeLastCell).Column
ÜB = WorksheetFunction.Transpose(TB2.Cells(1, S1).Resize(1, Off))
For i = S1 To LC2 Step 2
For j = 1 To Off
TB2.Cells(1, i + j - 1) = ÜB(j, 1) & "_" & LaufNr
Next
LaufNr = LaufNr + 1
Next
End With
End Sub