Hi,

Option Explicit

Sub Zusammenfügen()
Dim V, a&, b&, c&, E&, Zeile(), AlleZeilen(), temp
Dim CopyRow As Boolean

    With ActiveSheet
        V = .Range(.Cells(.Rows.Count, 1).End(xlUp), .Cells(1, 2)).Value
    End With
    E = UBound(V)
    
    b = 2
    ReDim Zeile(0, b)
    For a = 2 To E
        If V(a - 1, 1) = V(a, 1) Then
                                
            ReDim Preserve Zeile(0, b)
            Zeile(0, 0) = V(a, 1)
            Zeile(0, b - 1) = V(a - 1, 2)
            Zeile(0, b) = V(a, 2)
            b = b + 1
        
        Else
            CopyRow = True
        End If
        If CopyRow Or E = a Then
            
            If b = 2 Then
                ReDim Zeile(0, 2)
                Zeile(0, 0) = V(a - 1, 1)
                Zeile(0, 1) = V(a - 1, 2)
            Else
                b = 2
            End If
            
            ReDim Preserve AlleZeilen(c)
            AlleZeilen(c) = Zeile
            c = c + 1
            CopyRow = False
            
        End If
    Next
    If V(E - 1, 1) <> V(E, 1) Then
        ReDim Zeile(0, 2)
        Zeile(0, 0) = V(E, 1)
        Zeile(0, 1) = V(E, 2)
        ReDim Preserve AlleZeilen(c)
        AlleZeilen(c) = Zeile
        c = c + 1
    End If
    
    'out
        With ActiveSheet
            For a = 0 To c - 1
                .Range(.Cells(1 + a, 10), .Cells(1 + a, 10 + UBound(AlleZeilen(a), 2))) = AlleZeilen(a)
            Next
        End With
        
End Sub

Eigentlich war ich der Meinung das müsste recht einfach gehen, mir fällt allerdings grade nichts besseres ein... ist etwas komplizierter geworden. Man kann das sicherlich auch anders lösen.

Gruß

Till