Excel VBA-打卡系統

用VBA寫了一個簡單的打卡系統,可以判斷上班遲到早退以及加班時數

Private Sub CommandButton1_Click()
'r=>要準備寫資料的那一行 (ROW)
Dim r As Long
Dim d As Date
Dim t As Dated = Range("C3")
t = Range("C4")


'如果現在沒有資料,那麼r就從第二行開始寫 (r=2)
If Cells(10, 2) = "" Then
    r = 10
Else
    '如果有資料,找到最後一筆資料,並取得他的ROW
    Range("B9").Select
    Selection.End(xlDown).Select
    r = Selection.Row + 1

End If


'資料是從 r 開始寫入
Cells(r, 2) = Range("C2")
Cells(r, 4) = Range("C3")
Range("D" & r).Select
Selection.NumberFormatLocal = "yyyy/m/d"
Cells(r, 5) = Range("C4")
Range("E" & r).Select
Selection.NumberFormatLocal = "[$-x-systime]h:mm:ss AM/PM"

'顯示目前多少資料
Range("C7") = r - 10 + 1


'判斷上下班

If (DateDiff("h", t, "12:00:00")) > 0 Then
    Cells(r, 3) = "上班"
Else
    Cells(r, 3) = "下班"
End If

If (DateDiff("h", t, "9:30:00")) < 0 And (DateDiff("h", t, "9:00:00")) > 0 Then Cells(r, 6) = "遲到"
If (DateDiff("h", t, "18:00:00")) > 0 And (DateDiff("h", t, "12:00:00")) < 0 Then Cells(r, 6) = "早退"
If (DateDiff("h", t, "18:00:00")) < -1 And (DateDiff("h", t, "9:00:00")) < 0 Then
    out = -DateDiff("h", t, "19:00:00")
    Cells(r, 6) = "加班" & out & "小時"
End If


If r <> 10 And Cells(r - 1, 3) = "上班" And Cells(r, 3) = "上班" And DateDiff("d", d, Cells(r - 1, 4)) < 0 Then
    If Cells(r, 6) <> "" Then
        Text = Cells(r, 6)
        Cells(r, 6) = Text & " , 未登記下班"
    Else
        Cells(r, 6) = "未登記下班"
    End If

End If

If r <> 10 And Cells(r - 1, 3) = "上班" And Cells(r, 3) = "上班" And DateDiff("d", d, Cells(r - 1, 4)) = 0 Then
    Cells(r, 2) = ""
    Cells(r, 3) = ""
    Cells(r, 4) = ""
    Cells(r, 5) = ""
    Cells(r, 6) = ""
    MsgBox ("重複打卡")

End If

If r <> 10 And Cells(r - 1, 3) = "下班" And Cells(r, 3) = "下班" And DateDiff("d", d, Cells(r - 1, 4)) < 0 Then

    If Cells(r, 6) <> "" Then
        Text = Cells(r, 6)
        Cells(r, 6) = Text & " , 未登記上班"
    Else

        Cells(r - 1, 6) = "未登記上班"
    End If

End If

If r <> 10 And Cells(r - 1, 3) = "下班" And Cells(r, 3) = "下班" And DateDiff("d", d, Cells(r - 1, 4)) = 0 Then
    Cells(r, 2) = ""
    Cells(r, 3) = ""
    Cells(r, 4) = ""
    Cells(r, 5) = ""
    Cells(r, 6) = ""
    MsgBox ("重複打卡")

End If
End Sub