Anpassung

Sub Vergleichen()
Dim LoI As Long
Dim LoJ As Long
Dim LoLetzte1 As Long
Dim LoLetzte2 As Long
Dim Loletzte3 As Long
Dim c As Object
Dim z%
With Worksheets("Verweis")
LoLetzte1 = IIf(IsEmpty(.Range("A65536")), .Range("A65536").End(xlUp).Row, 65536)
End With
With Worksheets("sheet1")
LoLetzte2 = IIf(IsEmpty(.Range("B65536")), .Range("B65536").End(xlUp).Row, 65536)
End With
For LoI = 1 To LoLetzte1
' Leerzellen nicht kennzeichnen
Set c = Worksheets("Übersicht").Columns(1).Find(what:=Worksheets("Verweis").Cells(LoI, 1).Value, lookat:=xlWhole)
If Worksheets("Verweis").Cells(LoI, 1).Value <> "" And c Is Nothing Then
Set c = Worksheets("sheet1").Columns(2).Find(what:=Worksheets("Verweis").Cells(LoI, 1).Value, lookat:=xlWhole)
If Not c Is Nothing Then
startzeile = LoI
summe = Worksheets("Verweis").Cells(LoI, 2).Value
z = 1
zeile = LoI
Do
Set c = Worksheets("Verweis").Columns(1).Find(what:=Worksheets("Verweis").Cells(LoI, 1), after:=Worksheets("Verweis").Cells(zeile, 1), lookat:=xlWhole)
If c.Row <> startzeile Then
summe = summe + Worksheets("Verweis").Cells(c.Row, 2).Value
z = z + 1
zeile = c.Row
End If
Loop Until c.Row = startzeile
Worksheets("Verweis").Rows(LoI).Copy
With Worksheets("Übersicht")
Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
If Loletzte3 > 65536 Then
MsgBox "In Tabelle3 ist keine Zeile mehr frei"
Application.CutCopyMode = False
Exit Sub
End If
.Rows(Loletzte3).PasteSpecial Paste:=xlValues           ' Werte
.Rows(Loletzte3).PasteSpecial Paste:=xlFormats      ' Formate
.Cells(Loletzte3, 2).Value = summe
.Cells(Loletzte3, 3).Value = z
End With
End If
End If
Next LoI
Application.CutCopyMode = False
End Sub