Datum per VBA erfassen und fixieren

[srieth]

Hallo zusammen,

dies ist mein erster Beitrag, daher habt bitte etwas Nachsicht mit mir

Ich habe den Nachfolgenden VBA-Code bereits in einer meiner Excel-Dateien am Start und er funktioniert auch problemlos. 

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Target, Me.Columns(1)) Is Nothing Then
  For Each c In Intersect(Target, Me.Columns(1))
    If Not IsEmpty( c ) And IsEmpty(Me.Cells(c.Row, "K")) Then Me.Cells(c.Row, "K").Value = Date
  Next c
End If
End Sub


Was er bewirken soll ist folgendes: Sobald die Eingabe in einer Zeile getätigt wird, wird in einer definierten Zell das Datum der Eingabe hinterlegt und bei weiteren Eingaben auch nicht mehr verändert. Wie gesagt, in meinem Excel-File Nr. 1 funktioniert es so.

Nun möchte ich das Ganze jedoch in einem separaten Excel-File erweitern und müsste den oben erwähnten Code irgendwie erweitern, ich weiß jedoch nicht wie. Der "verbesserte Code" soll z.B. erkennen wenn in der Zelle AV1 eine Eingabe getätigt wird. Ist dies so, soll ebenfalls das Datum in Zelle BP1 geschrieben werden. Erfolgt in der selben Zeile (ggf. auch zu einen späteren Zeitpunkt) in Zelle AV1 eine Eingabe, soll in Zelle BQ1 ebenfalls ein Datum geschrieben und fixiert werden.

Das komplette Datenblatt hat 3.000 Zeilen und ich benötige die oben beschriebene Möglichkeit/Funktion in jeder einzelnen Zelle entsprechend gleich.

Kann mir jemand hierfür einen Code aufstellen den ich übernehmen kann? Danke!

[Werner.M]

Hallo,

meinst du so:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range

Select Case Target.Column
   Case 1
       For Each c In Target
           If c.Offset(, 10) = "" Then c.Offset(, 10) = Date
       Next c
   Case 48
       For Each c In Target
           If c.Offset(, 21) = "" Then c.Offset(, 21) = Date
       Next c
   Case Else
End Select
End Sub

Gruß Werner

[srieth]

Ich kann das nicht beurteilen. Was bewirkt dieser Code? Was ist unter Case 1 und Case 48 zu verstehen?

Vielleicht habe ich es zu umständlich beschrieben, daher nochmals in vereinfachter Version...

Wird in Zelle A1 etwas eingetippt, soll in Zelle C1 das Datum geschrieben werden und bei einer erneuten Eingabe in A1 das Datum nicht mehr überschrieben werden.
Wird in Zelle B1 etwas eingetippt, soll in Zelle D1 das Datum geschrieben werden und bei einer erneuten Eingabe in B1 das Datum nicht mehr überschrieben werden.

Dieses Vorgehen soll dann auf weiterhin auf alle darunter folgenden Zellen angewendet werden bis zur Zelle A3000, und eben die entsprechende Zellen C und D der jeweiligen Zeile.

Passt die Beschreibung so besser und ist verständlicher? Ich weiß sonst nicht, wie ich es besser ausrücken soll...

[Werner.M]

Hallo,

wieso jetzt plötzlich A1 und C1 bzw. B1 und C1?
Ich dachte A1 und K1 und AV1 und BQ1

Was hälst du denn davon, wenn du es einfach mal testest.

Unter Case wird die Spaltennummer, die auf Eingaben überwacht wird, als Zahl angegeben.

Spalte A = 1, Spalte AV = 48


Gruß Werner

[srieth]

Ich habe gedacht das vereinfacht es etwas. 

Ich habe den Code gerade in eine leere Seite kopiert, jedoch wird dann das Datum in sehr vielen Spalten ausgegeben bzw. viele Spalten werden ausgefüllt, wenn ich die Eingabe wieder lösche.

[Werner.M]

Hallo,

bei mir nicht, zu deiner Datei kann ich nichts sagen, da ich sie nicht kenne.

Bei mir wird in K5 das Datum ausgegeben, wenn ich in A4 was eintrage. Oder es wird in BQ10 das Datum ausgegeben, wenn ich in AV10 was eingebe.

Also bitte mal deine Mappe hier hochladen.


Gruß Werner

[schauan]

Hallöchen,

also, mal nur zum Verständnis im Code von Werner rumgewuselt, sollte so reichen. Es soll ja im Gegensatz zum ursprünglichen Code immer wieder bei Änderung ein Datum eingetragen werden. Das jetzt andere Spalten beackert werden sollen, hab ich nicht verarbeitet.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
   Case 1
            Target.Offset(, 10) = Date
   Case 48
           Target.Offset(, 21) = Date
End Select
End Sub