Zeile in Tables(ListObjects) schreiben

Sub Übertragen()
Dim LastRow As Long, rng As Range, raFund As Range
Dim wbZiel As Workbook, wsZiel As Worksheet
Dim tblZiel As ListObject
Application.ScreenUpdating = False
Set wbZiel = Workbooks.Open("https://upgreat365.sharepoint.com/sites/ServiceManagement/ _
Freigegebene%20Dokumente/SERVICE%20MANAGEMENT%20LIBRARY/1.%20Service%20Katalog/Servicematrix.xlsx?web=1")
Set wsZiel = wbZiel.Worksheets("Servicematrix")
Set tblZiel = wsZiel.ListObjects("AT_Servicematrix")
With ThisWorkbook.Worksheets("Offering")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rng In .Range("A5:A" & LastRow)
Set FoundCell = tblZiel.DataBodyRange.Columns(1).Find(what:=rng, LookIn:=xlValues,  _
lookat:=xlWhole)
If FoundCell Is Nothing Then
rng.EntireRow.Copy
With tblZiel
Set raFund = .DataBodyRange.Columns(1).Find(what:="*", LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlPrevious)
If Not raFund Is Nothing Then
MsgBox ("so weit ok")
'                     .Cells(raFund.Row, "A").Offset(1).PasteSpecial Paste:=xlPasteValues
'                     .Cells(raFund.ListObjects(", "A").Offset(1).PasteSpecial Paste:= _
xlPasteValues
End If
End With
Else
rng.EntireRow.Copy
UserForm2.Show
If boAbbruch Then
Application.CutCopyMode = False
Exit Sub
End If
If boAktualisieren Then
With wsZiel
.Cells(FoundCell.Row, "A").PasteSpecial Paste:=xlPasteValues
boAktualisieren = False
End With
Else
With wsZiel
Set raFund = .Columns("A").Find(what:="*", LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlPrevious)
If Not raFund Is Nothing Then
'hier geändert ##
'.Cells(raFund.Row, "A").End(xlUp).Offset(1).PasteSpecial _
Paste:=xlPasteValues
.Cells(raFund.Row, "A").Offset(1).PasteSpecial Paste:=xlPasteValues
End If
End With
End If
End If
Next rng
End With
'Zieldatei speichern
wbZiel.Save
'   wbZiel.Close True
Application.CutCopyMode = False
Set wbZiel = Nothing: Set wsZiel = Nothing: Set FoundCell = Nothing: Set raFund = Nothing
End Sub