MS Excel - Zeilen zusammenfassen, wie?

Option Explicit
Option Compare Text

Const Quelle = "Tabelle1"       'Tabelle Quelldaten  
Const Ziel = "Tabelle2"         'Tabelle Zieldaten  

Const StartZeile = 2            'Erste Zeile mit Daten  

Sub Zusammenfassen()
    Dim WksQ As Worksheet, Found As Object, Felder As Variant, i As Long
    Dim Spalte As Long, Zeile As Long, CopySpalte As Long, CopyZeile As Long
    
    Set WksQ = Sheets(Quelle)
    
    Application.ScreenUpdating = False
    
    With Sheets(Ziel)
        Felder = .Rows(1).Value
    
       .Cells.ClearContents
        
       .Rows(1).Value = Felder
        
        Zeile = StartZeile
        
        For i = StartZeile To WksQ.Cells(WksQ.Rows.Count, "A").End(xlUp).Row  
            If Not IsEmpty(WksQ.Cells(i, "A")) Then  
                Set Found = .Columns("A").Find(WksQ.Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)  
                
                If Found Is Nothing Then
                    Range(WksQ.Cells(i, "A"), WksQ.Cells(i, "B")).Copy .Cells(Zeile, "A")  
                    CopyZeile = Zeile:  Zeile = Zeile + 1
                Else
                    CopyZeile = Found.Row
                End If
                
                CopySpalte = WksQ.Cells(i, WksQ.Columns.Count).End(xlToLeft).Column
                
                WksQ.Cells(i, CopySpalte).Copy .Cells(CopyZeile, CopySpalte)
            End If
        Next
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Fertig!", vbInformation, "Meldung"  
End Sub