Bedingung ist, dass in B-E und H-K entweder 0 oder Leer ist. Ist in einem der Teile ein Wert, muss die Zeile bleiben, ansonsten soll die ganze Zeile gelöscht werden.
Hier das bisherige Makro:
Sub Ergaenzen()
Dim Erg() As Variant, OrgA() As Variant, OrgG() As Variant
Dim ErgZ As Long, zA As Long, zG As Long
ErgZ = 1
zA = 1
zG = 1
OrgA = Range("A3:E" & Range("A65536").End(xlUp).Row)
OrgG = Range("G3:K" & Range("E65536").End(xlUp).Row)
ReDim Erg(UBound(OrgA, 1) + UBound(OrgG, 1), 10)
Do Until zA > UBound(OrgA) Or zG > UBound(OrgG)
Select Case OrgA(zA, 1) 'A
Case Is = OrgG(zG, 1) ' A = G
For j = 1 To 5
Erg(ErgZ, j) = OrgA(zA, j)
Erg(ErgZ, j + 5) = OrgG(zG, j)
Next j
zA = zA + 1
zG = zG + 1
Case Is > OrgG(zG, 1) ' A > G
For j = 1 To 5
Erg(ErgZ, j) = OrgG(zG, j)
Erg(ErgZ, j + 5) = OrgG(zG, j)
Next j
zG = zG + 1
Case Else ' A < G
For j = 1 To 5
Erg(ErgZ, j) = OrgA(zA, j)
Erg(ErgZ, j + 5) = OrgA(zA, j)
Next j
zA = zA + 1
End Select
ErgZ = ErgZ + 1
Loop
Application.ScreenUpdating = False
Range("A3:K" & ErgZ + 2).Delete
For zA = 1 To ErgZ - 1
For j = 1 To 5
Cells(zA + 2, j) = Erg(zA, j)
Cells(zA + 2, j + 6) = Erg(zA, j + 5)
Next j
Next zA
Application.ScreenUpdating = True
End Sub