Option Explicit
Sub Bsp()
Dim rngT1 As Excel.Range
Dim rngT1H As Excel.Range
Dim rngT2 As Excel.Range
Dim rngT2H As Excel.Range
Dim rngCell As Excel.Range
Dim rngResult As Excel.Range
Dim strAddr As String
Set rngT1 = Worksheets("Tabelle1").UsedRange
Set rngT2 = Worksheets("Tabelle2").UsedRange
Call rngT1.Columns(1).Insert(xlShiftToRight)
Call rngT2.Columns(1).Insert(xlShiftToRight)
Set rngT1H = rngT1.Columns(1).Offset(, -1)
Set rngT2H = rngT2.Columns(1).Offset(, -1)
rngT1H.FormulaR1C1 = "=CONCATENATE(""'"",RC[1],""'"",""-"",""'"",RC[2],""'"")"
rngT2H.FormulaR1C1 = "=CONCATENATE(""'"",RC[1],""'"",""-"",""'"",RC[2],""'"")"
For Each rngCell In rngT2H.Cells
Set rngResult = rngT1H.Find(rngCell.Value, , LookIn:=xlValues, LookAt:=xlWhole)
If Not rngResult Is Nothing Then
strAddr = rngResult.Address
Do
If Not IsEmpty(rngT2.Cells(rngCell.Row, 3).Value) Then
Call rngT2.Rows(rngCell.Row).EntireRow.Offset(1).Insert(xlShiftDown)
rngT2.Cells(rngCell.Row + 1, 3).Value = rngResult.Offset(, 3).Value
Else
rngT2.Cells(rngCell.Row, 3).Value = rngResult.Offset(, 3).Value
End If
Set rngResult = rngT1H.FindNext(After:=rngResult)
Loop While rngResult.Address <> strAddr
End If
Next
Call rngT1H.Delete(xlShiftToLeft)
Call rngT2H.Delete(xlShiftToLeft)
End Sub