Office: (Office 365) VBA: Datum automatisch hinzufügen nach Übertrag

Hallo zusammen,

ich habe ein Makro gebaut, welches die Daten aus dem Tabellenblatt Bestellformular kopiert und diese in ein anderes Tabellenblatt (Bestellhistorie) überträgt, wobei zusätzlich in der Bestellhistorie das Datum ergänzt werden soll.

Status Quo: Das Kopieren der Zeilen funktioniert reibungslos, allerdings möchte ich bei jeder gefüllten Zeile das Datum in die nächste freie Spalte (in diesem Falle I) eintragen.

Problem: Aktuell wird das Datum nur in die nächste freie Zelle der Spalte I eingetragen.

Bereits vergeblich getestet: Das Datum per Change Event einzufügen klappt leider nicht ohne weiteres, da alle Zeilen statisch von 8 bis 50 kopiert werden und somit auch leere Zeilen mit einem Datum versehen werden.

Meine Überlegung wäre eine Art Schleife, bei der jede Zelle abgefragt wird, ob diese gefüllt ist und falls ja das Datum eingetragen wird. Allerdings konnte ich bislang in den Foren keine, für meinen Fall, funktionierenden Ansatz finden - hat hier jemand vielleicht noch eine Idee?


Dim Auftrag As Worksheet
Dim Historie As Worksheet

Set Auftrag = ThisWorkbook.Worksheets("Bestellformular")
Set Historie = ThisWorkbook.Worksheets("Bestellhistorie")

Auftrag.Range("C8:C50").Copy
Historie.Range("H" & Historie.Cells(Historie.Rows.Count, 8).End(xlUp).Row + 1).PasteSpecial _
Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False


Historie.Cells(Rows.Count, 9).End(xlUp).Offset(1).Value = Date



Besten Dank im voraus!

 

Hi,

versuche es mal so (ungetestet):

Code:

Historie.Cells(Rows.Count, 8).End(xlUp).Offset(0, 1).Value = Date

---

 

Hi Beverly,

vielen Dank für deine Idee! Mit deinem Code wird das Datum allerdings nur in die letzte beschriebene Zeile geschrieben und nicht in alle.

 

Hi,

da habe ich dich falsch verstanden.
Mit folgendem Code werden alle kopierten Zeilen durchlaufen und geprüft ob die Zelle nicht leer ist:

Code:

Dim Auftrag As Worksheet
Dim Historie As Worksheet
Dim lngLetzte As Long
Dim lngZeile As Long
Set Auftrag = ThisWorkbook.Worksheets("Bestellformular")
Set Historie = ThisWorkbook.Worksheets("Bestellhistorie")
With Historie
    lngLetzte = .Range("H" & .Cells(Rows.Count, 8).End(xlUp).Row + 1).Row
    Auftrag.Range("C8:C50").Copy
    .Cells(lngLetzte, 8).PasteSpecial _
        Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    For lngZeile = lngLetzte To lngLetzte + 51
        If .Cells(lngZeile, 8) <> "" Then .Cells(lngZeile, 9) = Date
    Next lngZeile
End With
Application.CutCopyMode = False

Weshalb willst du eigentlich auch leere Zeilen kopieren?

Bis später, Karin

 

Funktioniert super :) Danke für die super schnelle Unterstützung!

Zu den leeren Zeilen: mangels besseren Wissens kopiere ich auch die leeren Zeilen. Das geht sicherlich eleganter, aber damit wollte ich mir aber zusätzliche Kopfschmerzen bereiten und schnell Ergebnisse sehen. Verbesserungsvorschläge dazu werden natürlich dankend angenommen :)

 

Der einfachste Weg ist, in einer Schleife über den Bereich der Zeilen 8 bis 50 zu laufen und zu prüfen, ob die Zelle nicht leer ist:

Code:

Dim Auftrag As Worksheet
Dim Historie As Worksheet
Dim lngLetzte As Long
Dim lngZeile As Long
Set Auftrag = ThisWorkbook.Worksheets("Bestellformular")
Set Historie = ThisWorkbook.Worksheets("Bestellhistorie")
With Historie
    lngLetzte = .Range("H" & .Cells(Rows.Count, 8).End(xlUp).Row + 1).Row
    For lngZeile = 8 To 50
        If Auftrag.Cells(lngZeile, 3) <> "" Then
            .Cells(lngLetzte, 8) = Auftrag.Cells(lngZeile, 3).Value '<== nur Wert übernehmen
            .Cells(lngLetzte, 9) = Date
            lngLetzte = lngLetzte + 1  '<== Zielzeile um 1 erhöhen
        End If
    Next lngZeile
End With

---

 

Hui, das ist ja doch relativ simpel - funktioniert, tausend Dank!