Option Explicit
Sub Test()
Dim x As Long, c As Range, fc As String, sm As Double, flag As Boolean, z As Long
'_____________
'Ziel anpassen
With Sheets("Tabelle3")
On Error Resume Next
z = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row
On Error GoTo 0
End With
'_____________
'Quelle anpassen
With Sheets("Tabelle1")
For x = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row To 1 Step -1
If .Cells(x, 1).Value <> "" Then
fc = .Cells(x, 1).Address: sm = .Cells(x, 5).Value: flag = False
Set c = .Columns(1).Find(.Cells(x, 1).Value, .Cells(x, 1), xlValues, xlWhole, 2, 1)
If Not c Is Nothing And c.Address <> fc Then
Do
If c.Offset(, 3) = .Cells(x, 4) Then
sm = sm + c.Offset(, 4).Value: flag = True
c.Resize(, 5).ClearContents
End If
Set c = .Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> fc
End If
End If
If flag Then
.Cells(x, 5).Value = sm
z = z + 1
'_____________
'Ziel anpassen
.Cells(x, 1).Resize(, 5).Copy Sheets("Tabelle3").Cells(z, 1)
.Cells(x, 1).Resize(, 5).ClearContents
End If
flag = False
Next x
'_________
'wahlfrei
On Error GoTo Nix
For x = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row To 1 Step -1
If .Cells(x, 1).Value = "" Then .Rows(x).Delete
Next x
On Error GoTo 0
'_________
Nix:
End With
End Sub
|