Sub Kopieren()
Set quelle = Sheets("Tabelle1")
Set ziel = Sheets("Tabelle2")
lastrow = quelle.UsedRange.Rows.Count
spalte = 1
For i = 1 To lastrow
With quelle
Set frq = .Rows(i).Find("From: ")
If Not frq Is Nothing Then
Set frz = ziel.Rows(1).Find(frq.Value)
If Not frz Is Nothing Then
spalte = frz.Column
Else
spalte = ziel.Cells(1, Columns.Count).End(xlToLeft).Column + 1
ziel.Cells(1, spalte) = frq.Value
End If
End If
Set toq = .Rows(i).Find("To: ")
If Not toq Is Nothing Then
Set toz = ziel.Columns(spalte).Find(toq.Value)
If Not toz Is Nothing Then
zeile = toz.Row
Else
zeile = ziel.Cells(Rows.Count, spalte).End(xlUp).Row + 1
ziel.Cells(zeile, spalte) = toq.Value
End If
End If
End With
Next i
End Sub