CODE-SCHNIPSEL

Option Explicit
Option Compare Text
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_konsolidierung1.php
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.online-vba.de
' ****************************************************************

Public Sub OVBAde_TabellenKonsolidierung()
  Dim lQuellZeile As Long
  Dim lZielZeile As Long
  Dim lSpalte As Long
  Dim lSuchZeile As Long
  Dim oQuelle As Object
  Dim oZiel As Object
  Dim bFlag As Boolean
  Dim sVergleichQuelle As String
  Dim sVergleichZiel As String
    
    Set oQuelle = Sheets("Tabelle1")
    
    Set oZiel = Sheets.Add
    lZielZeile = 2
    
    Application.ScreenUpdating = False 'Flackern ausschalten
    
    'überschriften eintragen
    For lSpalte = 1 To 5
        oZiel.Cells(1, lSpalte).Value = oQuelle.Cells(1, lSpalte).Value
    Next lSpalte
    
    'Konsolidierung
    For lQuellZeile = 2 To oQuelle.UsedRange.Rows.Count + oQuelle.UsedRange.Row - 1
    
        bFlag = False
        
        'Prüfen ob Zeile schon vorhanden!
        For lSuchZeile = 2 To oZiel.UsedRange.Rows.Count + oZiel.UsedRange.Row - 1
            sVergleichQuelle = ""
            sVergleichZiel = ""
            For lSpalte = 1 To 4
                sVergleichQuelle = sVergleichQuelle & CStr(oQuelle.Cells(lQuellZeile, lSpalte).Text)
                sVergleichZiel = sVergleichZiel & CStr(oZiel.Cells(lSuchZeile, lSpalte).Text)
            Next lSpalte
            If LCase(Trim(CStr(sVergleichQuelle))) = LCase(Trim(CStr(sVergleichZiel))) Then
                bFlag = True
                Exit For
            End If
        Next lSuchZeile
        
        'Prüfergebnis entscheidet ob bereits vorhanden oder eine neue Zeile angelegt werden muss
        If bFlag = True Then 'Bereits vorhanden also nur anhängen
            oZiel.Cells(lSuchZeile, 5).Value = oZiel.Cells(lSuchZeile, 5).Text & _
                ", " & oQuelle.Cells(lQuellZeile, 5).Text
        Else 'Zeile als neu unten anhängen
            For lSpalte = 1 To 5
                'Inhalt übertragen ein führendes ' erzwingt die Textübernahme!!!
                oZiel.Cells(lZielZeile, lSpalte).Value = _
                    CStr("'" & oQuelle.Cells(lQuellZeile, lSpalte).Value)
            Next lSpalte
            lZielZeile = lZielZeile + 1
        End If
    Next lQuellZeile
    
    'Aufräumen
    Application.ScreenUpdating = True
    Set oZiel = Nothing
    Set oQuelle = Nothing
End Sub