在工厂 VBA MACRO 停留的时间

问题描述

格子里有日期和进出工厂的时间。我想计算每个人在他们来到工厂的那一天停留了多少小时。

为此,我编写了一个宏并将每个人定义为 sicil_no,因为它是一个唯一编号。但是由于在同一日期的不同时间有多个进入和退出,我需要编写一个代码来计算每个日期和 sicil_no(人)首先计算进入次数并存在然后减去然后添加它们以查找在工厂花费的总时间。

这就是我尝试做但做不到的方式。我在问题的末尾附上了一个简短的原始数据示例和一张图片。提前致谢

GECIS TARIHI SICIL NUMaraSI SoyaDI ADI GEÇİŞ YÖNÜ
04 03 2021 07:06:25 02491 约翰 CAN 条目
04 03 2021 09:28:01 02312 PLAT 7 月条目
04 03 2021 15:50:22 02312 PLAT 七月出口
04 03 2021 17:08:48 02491 JOHN CAN 退出
08 03 2021 07:06:45 02312 PLAT 7 月条目
08 03 2021 07:53:37 02260 BABER YOKY 条目
08 03 2021 13:05:38 02312 PLAT 七月出口
08 03 2021 13:18:30 02312 PLAT 7 月条目
08 03 2021 17:23:01 02312 PLAT 七月出口
08 03 2021 19:37:36 02260 BABER YOKY 退出

Sub macro()

Dim sicil_no As String  
Dim i As Integer
Dim end_row As Long 
Dim dates As Range 
Dim gecis_yonu As String 
Dim entry As String 
Dim Exits As String

end_row = Cells(Rows.Count,3).End(xlUp).Row


For i = 3 To end_row
    sicil_no = Cells(i,3).Value
    dates = Cells(i,1).Value

    If Range("J",i).Value = "Exit" Then
        Range("J",i).Value = exist
    End If
    
    If Range("J",i).Value = "Entry" Then
        Range("J",i).Value = entry
    End If
Next

For Each dates In Range("A",end_row)
    Range("M",i).Value = exist - entry
Next

enter image description here

解决方法

根据需要配置列和工作表名称。

Option Explicit

Sub CalcHours()

    ' configuration
    Const COL_DATETIME = "A"
    Const COL_ID = "B"
    Const COL_NAME = "C"
    Const COL_INOUT = "D"
    Const SHT_DATA = "Sheet1"
    Const SHT_REPORT = "Sheet2"

    Dim wb As Workbook,ws As Worksheet,rng As Range
    Dim i As Long,iLastRow As Long,dt As Date
    Dim person As clsPerson,ID As String,sInOut As String
    Dim people As Object,key
    Set people = CreateObject("Scripting.Dictionary")

    ' scan data
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(SHT_DATA)
    iLastRow = ws.Cells(Rows.Count,COL_ID).End(xlUp).Row
    For i = 2 To iLastRow
       ID = Trim(ws.Cells(i,COL_ID))
       If people.exists(ID) Then
           Set person = people(ID)
       Else
           Set person = New clsPerson
           person.ID = ID
           person.Name = ws.Cells(i,COL_NAME)
           people.Add ID,person
       End If
       
       ' string to date
       dt = ParseDate(ws.Cells(i,COL_DATETIME),i)
       If dt = 0 Then Exit Sub
       sInOut = Trim(UCase(ws.Cells(i,COL_INOUT))) ' entry/exit
       If sInOut = "ENTRY" Then
           person.ClockIn dt
       ElseIf sInOut = "EXIT" Then
           person.ClockOut dt
       Else
           MsgBox "ERROR Entry/Exit =  " & sInOut,vbCritical,"Row " & i
       End If

    Next

    ' report results
    Set ws = wb.Sheets(SHT_REPORT)
    ws.Cells.Clear
    ws.Range("A1:G1") = Array("ID","Name","Date","Total Hours","Entry","Exit","Hours")
    Set rng = ws.Range("A2")
    For Each key In people.keys
        people(key).timesheet rng
    Next
    ws.Columns("A:G").AutoFit
    ws.Activate
    rng.Select

    MsgBox " See report on " & ws.Name,vbInformation,"Count = " & people.Count

End Sub

Function ParseDate(s As String,i As Long) As Date
    
    Dim ar
    If s Like "## ## #### ##:##:##" Then
        ar = Split(Application.Trim(s)," ")
        ParseDate = DateSerial(ar(2),ar(1),ar(0)) + CDate(ar(3))
    Else
        MsgBox "Can not parse " & s & " on Row " & i,"ParseDate()"
        ParseDate = 0
        Exit Function
    End If
    
End Function


Class Module clsPerson
======================
Option Explicit

'clsPerson
Public ID As String
Public Name As String
Public Dates As New Collection
Public atWork As Boolean

' person clocks in
Public Sub ClockIn(dt As Date)

    Dim msg As String
    ' check not already clocked in
    If atWork Then
         msg = "ERROR - Repeat Entry for " & Me.ID & " " & Me.Name & " On " & dt
         MsgBox msg,"clsPerson"
    End If
    Me.atWork = True

    Dim dtWork As Date,workday As clsWorkDay
    Dim n As Integer,isNew As Boolean
    dtWork = Int(dt)
    n = Dates.Count
    If n = 0 Then
       isNew = True
    Else
       If Dates(n).day = dtWork Then
          Set workday = Dates(n)
       Else
          isNew = True
       End If
    End If
    If isNew Then
        Set workday = New clsWorkDay
        workday.day = dtWork
        Me.Dates.Add workday,CStr(n + 1)
    End If
    workday.ClockIn dt

End Sub

' person clocks out
Public Sub ClockOut(dt As Date)

    Dim msg As String
    ' check is clocked in
    If Not atWork Then
         msg = "ERROR - Repeat Exit for " & Me.ID & " " & Me.Name & " On " & dt
         MsgBox msg,"clsPerson"
    End If
    Me.atWork = False

    Dim dtWork As Date,workday As clsWorkDay,n As Integer
    dtWork = Int(dt)
    n = Dates.Count
    If n = 0 Then
        msg = "ERROR - No dates for " & Me.ID & " " & Me.Name
        MsgBox msg,"clsPerson"
    Else
        Set workday = Dates(n)
        workday.ClockOut dt
    End If

End Sub

Public Sub timesheet(ByRef rng As Range)
    Dim workday As clsWorkDay,shift As clsShift
    rng.Offset(0,0) = Me.ID
    rng.Offset(0,1) = Me.Name

    For Each workday In Me.Dates
       rng.Offset(0,2) = workday.day
       rng.Offset(0,3) = Format(workday.HoursWorked,"0.00")
       For Each shift In workday.shifts
          rng.Offset(0,4) = shift.ClockIn
          rng.Offset(0,5) = shift.ClockOut
          rng.Offset(0,6) = Format(shift.HoursWorked,"0.00")
          Set rng = rng.Offset(1)
       Next
    Next

End Sub

Class Module clsWorkDay
=======================
Option Explicit

' clsWorkDay
Public day As Date
Public HoursWorked  As Single
Public shifts As New Collection
Public atWork As Boolean

Public Sub ClockIn(dt As Date)

    Dim shift As clsShift,msg As String
    If Me.atWork = True Then
        msg = "ERROR - Repeat Entry " & dt
        MsgBox msg,"clsWorkDay"
    End If
    Me.atWork = True
       
    Set shift = New clsShift
    shift.ClockIn = dt
    shift.atWork = True
    shifts.Add shift
    
End Sub

Public Sub ClockOut(dt As Date)

    Dim shift As clsShift,msg As String,n As Integer
    If Me.atWork = False Then
        msg = "ERROR - Repeat Exit " & dt
        MsgBox msg,"clsWorkDay"
    End If
    Me.atWork = False
       
    ' get last shift
    n = shifts.Count
    If n > 0 Then
        Set shift = shifts(n)
        shift.ClockOut = dt
        shift.HoursWorked = DateDiff("s",shift.ClockIn,shift.ClockOut) / 3600
        Me.HoursWorked = Me.HoursWorked + shift.HoursWorked
        shift.atWork = False
    Else
        MsgBox "ERROR - No shift to Exit from at " & dt,"clsWorkDay"
    End If
    
End Sub

Class Module clsShift
=====================
Option Explicit
' clsShift
Public ClockIn As Date
Public ClockOut As Date
Public HoursWorked As Single
Public atWork As Boolean