Datum + Zeitstempel in Liste eintragen

[Kai Schröder]

Hallo zusammen,

in beigefügter Liste möchte ich gerne, dass beim Scannen eines Barcodes aus dem Datenblatt "Barcodes" im Datenblatt "Eintrag"
ein Zeitstempel hinterlegt wird. Liste dazu kann fortlaufend sein. 

Ausgabe = 
Wert aus Barcode -> "Eintrag" Spalte A
"Eintrag" Spalte B = Zeitstempel

Nun habe ich das Problem, dass sich der Zeitstempel immer für alle Felder aktualisiert und komme nicht dahinter,
wie ich das lösen kann.

Kann mir jemand helfen? (Hoffe ihr versteht meine Schilderung) 

Grüße

Kai

[UweD]

Hallo

- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- Code rechts reinkopieren

dann...

- markiere auf Blatt "Eintrag" Spalte A:B
- Rechtsclick; Zellen formatieren
- unter Schutz den Haken raus

- Rechtsclick auf den Tabellenblattreiter
- Blatt schützen; Haken bei "Gesperrte Zellen auswählen" rausnehmen; OK

- A2 auswählen und scannen

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Fehler
    Const APPNAME = "Worksheet_Change"
   
    If Not Intersect(Range("A:A"), Target) Is Nothing Then
        If Target.Count > 1 Then
            MsgBox "Zellen nur einzeln bearbeiten", vbOKOnly
            With Application
                .EnableEvents = False
                .Undo
            End With
            Exit Sub
        End If
       
        If Target <> "" Then
       
            Application.EnableEvents = False
            Target.Offset(0, 1) = Format(Now, "YYYY.MM.DD hh:mm:ss")
           
            Target.Offset(1, 0).Select
        End If
    End If
   
   
    '*** Fehlerbehandlung
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

---

Hallo


zusätzlich noch ein paar Prüfungen

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Scann As String
    Dim TB1 As Worksheet, Sp As Integer
   
    Set TB1 = Sheets("Barcodes")
    Sp = 1 'Prüfung aus Spalte A
   
   
    On Error GoTo Fehler
    Const APPNAME = "Worksheet_Change"
   
   
    If Not Intersect(Range("A:A"), Target) Is Nothing Then
        If Target.Count > 1 Then
            MsgBox "Zellen nur einzeln bearbeiten", vbOKOnly
            With Application
                .EnableEvents = False
                .Undo
                .EnableEvents = True
            End With
            Exit Sub
        End If
       
        If InStr(Target, " ") > 0 Then
            Scann = Left(Target, InStr(Target, " ") - 1)
            If WorksheetFunction.CountIf(TB1.Columns(Sp), Scann) > 0 Then
           
                Application.EnableEvents = False
                Target.Offset(0, 1) = Format(Now, "YYYY.MM.DD hh:mm:ss")
               
                Target.Offset(1, 0).Select
            Else
                MsgBox "Artikelnummer '" & Scann & "' nicht vorhanden", vbOKOnly
                With Application
                    .EnableEvents = False
                    .Undo
                    .EnableEvents = True
                End With
            End If
        Else
            MsgBox "Scan fehlerhaft", vbOKOnly
            With Application
                .EnableEvents = False
                .Undo
                .EnableEvents = True
            End With
        End If
    End If
   
   
    '*** Fehlerbehandlung
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

[Kai Schröder]

        Moin Uwe!

Danke vielmals, erstmal macht der Code genau was ich beschrieben hatte. (Sogar etwas mehr)

Habe nun noch die Schwierigkeit, dass ich den Wert aus Spalte "A" in einem anderen Tabellenblatt
ausgeben möchte, aber NUR den Wert des letzten/aktuellsten Zeitstempels.
Da kommt mein Sverweis leider an seine Grenzen, der zeigt mir nur den ersten Wert in der Liste...

Hat nochmal jemand einen Tipp? 

[
Bild bitte so als Datei hochladen: Klick mich!
]

[Kai Schröder]

Guten Morgen zusammen!

Hat jemand eine Idee? 
Hab die Datei nochmal hinzugefügt.

Wäre klasse, wenn hier jemand helfen könnte!

[UweD]

Hallo nochmal

Code:

Dashboard B2: =VERWEIS(2;1/(Eintrag!$D$2:$D$10000=[@Artikel]);Eintrag!$A$2:$A$10000)

und runterkopieren


LG UweD

[Kai Schröder]

Klasse! Danke Dir!