Datum eintragen - Datensatz archivieren - (Fortsetzung)
22.08.2023 18:23:02
Lilli
dieses Threads ist fortsetzung von diesem Threads:
https://www.herber.de/forum/cgi-bin/callthread.pl?index=1943103
ich war leider krank und konnte leider nicht rechtzeitig auf die Antworten reagieren.
Sub ArchivierenundDatum_Klicken()
Dim r, rngZiel As Range, lr As ListRow
With Sheets("datenarchiv").ListObjects(1)
For Each lr In .ListRows
If Application.CountA(lr.Range) = 0 Then
Set rngZiel = lr.Range.Cells(1)
Exit For
End If
Next lr
End With
If rngZiel Is Nothing Then
With Sheets("datenarchiv").ListObjects(1)
Set rngZiel = .ListRows.Add.Range.Cells(1)
End With
End If
With Sheets("Daten").ListObjects(1)
r = Application.Match(Range("D9"), .DataBodyRange.Columns(1), 0)
If Not IsError(r) Then
.DataBodyRange.Cells(r, 1).Resize(, 9).Copy
With rngZiel
.PasteSpecial xlPasteValues
.Offset(, 9) = Now
End With
.DataBodyRange.Cells(r, 2).Resize(, 8).ClearContents
End If
End With
End SubLink zu Datei: https://www.herber.de/bbs/user/162334.xlsm
Das übertragen und hinzufügen klappt ganz gut. Allerdings wird die Position mitgenommen und somit mehrmals den gleichen Position in der Archivierung. Die erste Spalte sollte bitte nicht mitgenommen werden. Also ab dem zweiten Spalte. Wie würde dann den Code aussehen. Ich kann es nur testen. meine VBA Kenntnisse gehen Richtung null.
für das Datum eintragen habe ich bereits folgendes Code bekommen und das funktioniert auch sehr gut.
Sub DatumundUhrzeit_Klicken()
Dim r
With Sheets("Daten").ListObjects("daten.tbl")
r = Application.Match(Range("D9"), .DataBodyRange.Columns(1), 0)
If Not IsError(r) Then
.DataBodyRange.Cells(r, 9) = Now
End If
End With
End SubDer Kollege Rudi hat mir beim letzten Thread geholfen, worüber ich mich sehr freue und sehr dankbar bin. Ich freue mich über jede Hilfe, die ich bekommen kann.
Vielen Dank für die Mühe und Feedback im Voraus.
Liebe Grüße, Lilli