Option Explicit
Sub Tabelle3_Test()
Application.ScreenUpdating = False
On Error GoTo ErrHandler
Call UsedRange.Delete
Dim rngT1Body As Excel.Range
Dim rngT2Body As Excel.Range
Set rngT1Body = Tabelle1.UsedRange
Set rngT2Body = Tabelle2.UsedRange
Call rngT1Body.Copy(Range("A1"))
Call rngT2Body.Copy(Range("A1").Offset(, rngT1Body.Columns.Count))
Set rngT1Body = Range("A1").Resize(rngT1Body.Rows.Count, rngT1Body.Columns.Count)
Set rngT2Body = Range("A1").Offset(, rngT1Body.Columns.Count).Resize(rngT2Body.Rows.Count, rngT2Body.Columns.Count)
Call rngT1Body.Sort(rngT1Body.Cells(1, 2), xlAscending, Header:=xlYes)
Call rngT2Body.Sort(rngT2Body.Cells(1, 1), xlAscending, Header:=xlYes)
Set rngT1Body = rngT1Body.Rows(2)
Set rngT2Body = rngT2Body.Rows(2)
Do While rngT1Body.Cells(1, 2).Value <> "" Or rngT2Body.Cells(1, 1).Value <> ""
If rngT2Body.Cells(1, 1).Value = rngT2Body.Cells(rngT2Body.Rows.Count + 1, 1).Value Then
Set rngT2Body = rngT2Body.Resize(rngT2Body.Rows.Count + 1)
ElseIf rngT1Body.Cells(1, 2).Value = rngT2Body.Cells(1, 1).Value Then
Call rngT1Body.Offset(1).Resize(rngT2Body.Rows.Count - 1).Insert(xlShiftDown)
Call rngT1Body.Copy(rngT1Body.Offset(1).Resize(rngT2Body.Rows.Count - 1))
If rngT1Body.Row = rngT2Body.Row + rngT2Body.Rows.Count Then
Call rngT2Body.Offset(rngT2Body.Rows.Count).Insert(xlShiftDown)
Call rngT2Body.Copy(rngT2Body.Offset(rngT2Body.Rows.Count))
End If
Set rngT1Body = rngT1Body.Offset(rngT2Body.Rows.Count)
Else
Set rngT2Body = rngT1Body.Offset(, 2)
If rngT2Body.Cells(1, 1).Value <> rngT1Body.Cells(1, 2).Value Then
Call rngT2Body.Delete(xlShiftUp)
Set rngT2Body = rngT1Body.Offset(, 2)
End If
End If
Loop
Call rngT1Body.Cells(1, 2).EntireColumn.Delete(xlShiftToLeft)
GoTo SafeExit
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
SafeExit:
Application.ScreenUpdating = True
End Sub