Name Zieldatei in Ursprungsdatei eintragen
04.08.2017 10:15:08
Basti
den u.a. Code hatte mir mein Namensvetter im Beitrag "Markierte Zeile per VBA in andere Mappe kopieren" vom November 2016 erstellt.
Funktioniert Prima und übertägt mir die aktuell markierte Zeile in eine andere Datei auf meinem Laufwerk.
Habe nun versucht den Code so zu erweitern, sodass in der jeweils markierten Zeile in Spalte "X" das aktuelle Datum und der Name der Zieldatei eingetragen wird. Leider bisher ohne Erfolg.
Beispielergebnis: Spalte X in Zeile 500 = 04.08.2017: Diese Zeile wurde in "NameZieldatei.xlsx" übertragen.
Evtl. kann mich einer von Euch unterstützen.
Vielen Dank
Basti
Sub myCopy3()
Dim objXLApp As Excel.Application
Dim objXLABC As Excel.Workbook
Dim objXLWorkbooks As Excel.Workbooks
Dim neuWkb
Dim lngLastRow As Long
Dim rng As Range
Dim i As Long
Dim rr As Long
Dim zells As Range
rr = Selection.Row
Set rng = ActiveSheet.Range("A1,C1,D1,G1,J1").Offset(rr - 1)
Set objXLApp = New Excel.Application
Set objXLWorkbooks = objXLApp.Workbooks
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set objXLABC = objXLWorkbooks.Open("C:\Users\bastian\Desktop\Neu.xlsx")
neuWkb = objXLABC.Name
With objXLWorkbooks(neuWkb).Sheets(1)
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngLastRow = 1 Then
Laufendezahl = 1
Else
Laufendezahl = .Cells(lngLastRow, 1) + 1
End If
.Cells(lngLastRow + 1, 1) = Laufendezahl
.Cells(lngLastRow + 1, 2) = Application.UserName
.Cells(lngLastRow + 1, 3) = Now
i = 3
For Each zell In rng
i = i + 1
.Cells(lngLastRow + 1, i) = zell
Next
End With
objXLWorkbooks(neuWkb).Close savechanges:=True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objXLApp = Nothing
Set objXLWorkbooks = Nothing
End Sub
Anzeige