Hallo,

beim, ersten Lesen habe ich überlesen, dass zuvor die zusammenfassenden Zellen markiert werden.

Voraussetzung: Die Zusammenfassenden Inhalte wurden benannt mit "Daten". (siehe Muster-Arbeitmappe, weiter unten)

In dem Fall ist es recht einfach:

Sub ZusammenfassenZeilen()
    Dim wsh As Worksheet
    Dim rngTab As Range
    Dim rngRow As Range
    Dim strName As String
    Dim iCol As Integer, iColPos As Integer
    Dim col As New Collection
    Set wsh = ActiveSheet
    Set rngTab = wsh.Names("Daten").RefersToRange
    
    For Each rngRow In rngTab.Rows
        If Not Intersect(Selection, rngRow) Is Nothing Then
            col.Add rngRow
            NewName strName, rngRow.Cells(1, 1).value
        End If
    Next
    
    If col.Count > 1 Then
        col.Item(1).Cells(1, 1).value = strName
        For iColPos = 2 To col.Count
            For iCol = 2 To rngTab.Columns.Count
                If col.Item(iColPos).Cells(1, iCol).value <> "" Then
                    col.Item(1).Cells(1, iCol).value = col.Item(iColPos).Cells(1, iCol).value
                End If
            Next
            col.Item(iColPos).Delete
        Next
        col.Item(1).Cells(1, 1).Select
    End If
End Sub

Sub NewName(ByRef strName As String, ByVal value As String)
    Dim iPos As Integer
    Dim strPos As String
    Dim strValue As String
    If strName = "" Then
        strName = value
    Else
        ' Numerische Zeichen ermitteln
        For iPos = 1 To Len(value)
            strPos = Mid(value, iPos, 1)
            If Asc(strPos) >= 48 And Asc(strPos) <= 57 Then
                strValue = strValue & strPos
            End If
        Next
        strName = strName & strValue
    End If
End Sub

Diese Sub fasst alle Zeilen in der markierten Tabelle zusammen.

Wenn Spalten zusammengefasst werden sollen, muss die folgende Sub aufgerufen werden:

Sub ZusammenfassenSpalten()
    Dim wsh As Worksheet
    Dim rngTab As Range
    Dim bDiff As Boolean
    Dim iCol As Integer, iColChk As Integer, iRow As Integer
    Set wsh = ActiveSheet
    Set rngTab = wsh.Names("Daten").RefersToRange
    
    iCol = 2
    Do While iCol < rngTab.Columns.Count
        iColChk = iCol + 1
        Do While iColChk <= rngTab.Columns.Count
            bDiff = False
            For iRow = 1 To rngTab.Rows.Count
                If Not rngTab.Cells(iRow, iCol).value = rngTab.Cells(iRow, iColChk).value Then
                    bDiff = True
                    Exit For
                End If
            Next
            If Not bDiff Then
                Range(rngTab.Cells(1, iColChk), rngTab.Cells(rngTab.Rows.Count, iColChk)).Delete
            Else
                iColChk = iColChk + 1
            End If
        Loop
        iCol = iCol + 1
    Loop
End Sub

Eine Muster-Arbeitsmappe kann hier heruntergeladen werden.

LG, BigBen