Meine bisherigen Versuche das Script so anzupassen, dass neue Zeilen innerhalb der Table geschrieben werden, haben leider nicht gefruchtet. Wenigstens funktioniert das aktualisieren einer Zeile, aber nun komme ich nicht weiter.
Wäre super, wenn mir jemand helfen könnte
Danke im Voraus
Herby
Zieldatei mit Table
https://www.herber.de/bbs/user/139229.xlsx
An der Stelle wo's Klemmt habe ich eine Message Box eingebaut und die fehlerhafte Copy Zeile ist auskommentiert
PS: sorry dass nicht der ganze Code im Fenster ist, aber irgendwie ist der button zum Einfügen von Code verschwunden :(
Option Explicit
Public FoundCell As Range
Public boAktualisieren As Boolean
Public boAbbruch As Boolean
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