AW: Stempeluhr RFID Leser und VBA
19.10.2018 10:14:58
UweD
Hier nochmal mit Vorbelegung der Spalten
Microsoft Excel Objekt Tabelle1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Chip As Variant, MA As String
Dim Datum As Date, Dauer As Date
Dim Z1 As Integer, TB, iZ As Double, WF
Dim SpChip As Integer, SpDatum As Integer, SpZeit As Integer
Dim SpMA As Integer, SpArt As Integer, SpDauer As Integer
On Error GoTo Fehler
Z1 = 1
If Target.Column = 1 And Target.Row > Z1 And Target.Count = 1 And Target <> "" Then
Set TB = Sheets("Stammdaten") ' Daten liegen in A:B
Set WF = WorksheetFunction
'Spaltenfestlegung
SpChip = 1: SpDatum = 2: SpZeit = 3: SpMA = 4: SpArt = 5: SpDauer = 6
iZ = Target.Row
Chip = Target.Value
Application.EnableEvents = False
If WF.CountIf(TB.Columns("A:A"), Chip) > 0 Then
MA = WF.VLookup(Chip, TB.Columns("A:B"), 2, 0)
Else
MsgBox "unbekannter Chip '" & Chip & "'"
Target.ClearContents
GoTo Fehler
End If
Datum = Now
Cells(iZ, SpDatum) = Datum
Cells(iZ, SpZeit) = Format(Datum, "hh:mm")
Cells(iZ, SpMA) = MA
If WF.CountIf(Cells(Z1, SpMA).Resize(iZ - Z1 + 1, 1), MA) Mod 2 = 1 Then
Cells(iZ, SpArt) = "Kommen"
Else
Cells(iZ, SpArt) = "Gehen"
Dauer = Datum - _
WF.MaxIfs(Cells(Z1, SpDatum).Resize(iZ - Z1, 1), Cells(Z1, SpMA).Resize(iZ - Z1), MA)
Cells(iZ, SpDauer) = WF.Ceiling(Dauer, "00:01:00") 'Aufrunden auch ganze Minuten
Cells(iZ, SpDauer).NumberFormat = "[hh]:mm"
End If
End If
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD