20190319xlVBA_根据考勤数据统计缺勤缺考数据

Sub SubtotalPickFile()
    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer
    Dim firstday As Date, lastday As Date
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim Dic As Object
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    Set ud = CreateObject("Scripting.Dictionary")
    Set Dic = CreateObject("Scripting.Dictionary")
    Dim onDay, onTime, offTime
    Const ON_TIME = "8:30:00"
    Const OFF_TIME = "17:00:00"
    Const MID_TIME = "12:00:00"
    Dim onForget, offForget, onLate, offEarly, forgetTime, lateTime, earlyTime, duration
    Dim lateday, earlyday, forgetday
    Set Wb = ThisWorkbook
    
    '选取考勤数据文件
    FilePath = FilePicker()
    If FilePath = "" Then Exit Sub
    Set OpenWb = Application.Workbooks.Open(FilePath)
    Set Sht = OpenWb.Worksheets(1)
    With Sht
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A3:F" & endrow)
        arr = Rng.Value
    End With
    OpenWb.Close False
    
    '设置考勤起止日期
    startday = Application.InputBox("请输入起始日期，格式为 2019/01/01 : ", "InputBox", , , , , , 2)
    If startday = False Then
        MsgBox "没有输入日期！"
        Exit Sub
    End If
   endday = Application.InputBox("请输入结束日期，格式为 2019/01/31 : ", "InputBox", , , , , , 2)
    If endday = False Then
        MsgBox "没有输入日期！"
        Exit Sub
    End If
    
    '计算工作日天数
    On Error Resume Next
    firstday = CDate(startday)
    lastday = CDate(endday)
    'wkdays = WorkdaysBetween(firstday, lastday)
    
    counter = 0
    today = firstday
    Do
                Key = Format(today, "yyyy/mm/dd")
        If Weekday(today, vbMonday) <= 5 Then
            counter = counter + 1

            d(Key) = ""
            ''debug.Print today; " 是工作日  "; counter
        Else
            ud(Key) = ""
            ''Debug.Print today; " 是工作日  "; counter
        End If
        
        today = DateAdd("d", 1, today)
        If today = DateAdd("d", 1, lastday) Then Exit Do
    Loop
    wkdays = counter
    
    
    
    
    If Err.Number <> 0 Then
        Exit Sub
        MsgBox "输入的日期范围可能有误!", vbInformation, "Information"
    End If
    
    Set oSht = Wb.Worksheets("result")
    For i = LBound(arr) To UBound(arr)
        Key = CStr(arr(i, 2))
        td = CDate(arr(i, 4))
        If DateDiff("d", firstday, td) >= 0 And DateDiff("d", td, lastday) >= 0 Then
            ''debug.Print td; "   符合要求"
            '截取上下班时间
            onTime = CDate(Split(arr(i, 5), " ")(1))
            offTime = CDate(Split(arr(i, 6), " ")(1))
            onForget = False
            offForget = False
            
            '计算工作时长
            duration = DateDiff("n", onTime, offTime)
            If Not Dic.Exists(Key) Then
                lateTime = 0
                earlyTime = 0
                forgetTime = 0
                forgetday = ""
                lateday = ""
                earlyday = ""
                onDay = 1
                '迟到判断
                onLate = (DateDiff("s", CDate(ON_TIME), onTime) > 0)
                onForget = (DateDiff("s", CDate(MID_TIME), onTime) > 0)
                If onForget Then
                    forgetTime = forgetTime + 1
                    forgetday = arr(i, 4) & "上午"
                Else
                    If onLate Then
                        If duration < 510 Then
                            lateTime = lateTime + 1
                            If lateday = "" Then
                                lateday = arr(i, 4) & "上午"
                            Else
                                lateday = lateday & vbCrLf & arr(i, 4) & "上午"
                            End If
                        End If
                    End If
                End If
                '早退判断
                offEarly = (DateDiff("s", offTime, CDate(OFF_TIME)) > 0)
                offForget = (DateDiff("s", CDate(MID_TIME), offTime) < 0)
                If offForget Then
                    forgetTime = forgetTime + 1
                    If forgetday <> "" Then
                        forgetday = forgetday & vbCrLf & arr(i, 4) & "下午"
                    Else
                        forgetday = arr(i, 4) & "下午"
                    End If
                Else
                    If offEarly Then
                        If duration < 510 Then
                            earlyTime = earlyTime + 1
                            If earlyday = "" Then
                                earlyday = arr(i, 4) & "下午"
                            Else
                                earlyday = earlyday & vbCrLf & arr(i, 4) & "下午"
                            End If
                        End If
                    End If
                End If
                ar = Array(arr(i, 1), arr(i, 2), arr(i, 3), wkdays, onDay, 0, Format(arr(i, 4), "yyyy/mm/dd"), lateTime, lateday, earlyTime, earlyday, forgetTime, forgetday)
                Dic(Key) = ar
            Else
                ar = Dic(Key)
                ar(4) = ar(4) + 1
                ar(6) = ar(6) & ";" & Format(arr(i, 4), "yyyy/mm/dd")
               'If Key = "2018000766" Then Debug.Print td; "    ----------"; ar(6)
                '迟到判断
                onLate = (DateDiff("s", CDate(ON_TIME), onTime) > 0)
                onForget = (DateDiff("s", CDate(MID_TIME), onTime) > 0)
                If onForget Then
                    ar(11) = ar(11) + 1
                    If ar(12) <> "" Then
                        ar(12) = ar(12) & vbCrLf & arr(i, 4) & "上午"
                    Else
                        ar(12) = arr(i, 4) & "上午"
                    End If
                Else
                    If onLate Then
                        If duration < 510 Then
                            ar(7) = ar(7) + 1
                            If ar(8) = "" Then
                                ar(8) = arr(i, 4) & "上午"
                            Else
                                ar(8) = ar(8) & vbCrLf & arr(i, 4) & "上午"
                            End If
                        End If
                    End If
                End If
                '早退判断
                offEarly = (DateDiff("s", offTime, CDate(OFF_TIME)) > 0)
                offForget = (DateDiff("s", CDate(MID_TIME), offTime) < 0)
                If offForget Then
                    ar(11) = ar(11) + 1
                    If ar(12) <> "" Then
                        ar(12) = ar(12) & vbCrLf & arr(i, 4) & "下午"
                    Else
                        ar(12) = arr(i, 4) & "下午"
                    End If
                Else
                    If offEarly Then
                        If duration < 510 Then
                            ar(9) = ar(9) + 1
                            If ar(10) = "" Then
                                ar(10) = arr(i, 4) & "下午"
                            Else
                                ar(10) = ar(10) & vbCrLf & arr(i, 4) & "下午"
                            End If
                        End If
                    End If
                End If
                Dic(Key) = ar
            End If
        End If
    Next i
    
    '计算缺考天数和缺考日期
    'On Error Resume Next
    For Each K In Dic.keys
        ar = Dic(K)
        ar(4) = UBound(ar(6)) + 1
        ar(5) = ar(3) - ar(4)
          'If K = "2018000766" Then Debug.Print "缺考天数 ： "; ar(5)
          'If K = "2018000766" Then Debug.Print ar(2); " 打卡日期： "; ar(6)
         s = ""
         For Each wd In d.keys
             'If K = "2018000766" Then Debug.Print "工作日》》"; wd
             'If K = "2018000766" Then Debug.Print "判断日期在不在工作日内："; wd; "  "; InStr(ar(6), wd)
            If InStr(ar(6), wd) <= 0 Then
                If s = "" Then
                    s = wd & "缺考"
                Else
                    s = s & vbCrLf & wd & "缺考"
                End If
            End If
         Next wd
         
         w = ""
         For Each u In ud.keys
            If K = "2018000766" Then Debug.Print "非工作日》》"; u
            If K = "2018000766" Then Debug.Print "判断日期在不在工作日内："; u; "  "; InStr(ar(6), u)
            If InStr(ar(6), u) > 0 Then
                If w = "" Then
                    w = u & "加班"
                Else
                    w = w & vbCrLf & u & "加班"
                End If
            End If
         Next u
         
 
           'If K = "2018000766" Then Debug.Print ar(2); " 缺考日期： "; s
           'If K = "2018000766" Then Debug.Print ar(2); " 加班日期： "; w
        ar(6) = s & vbCrLf & w
        Dic(K) = ar
           
   
    Next K
    
    
    With oSht
        .UsedRange.Offset(2).Clear
        Set Rng = .Range("A3")
        Set Rng = Rng.Resize(Dic.Count, 13)
        Rng.Value = Application.Rept(Dic.Items, 1)
        Sort_2003 Rng, False
        SetCenters .UsedRange
        SetBorders .UsedRange
        .Activate
        Rows("3:3").Select
        ActiveWindow.FreezePanes = True
    End With
    
    Call StepForward
    
    UsedTime = VBA.Timer - StartTime
    ''debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    Set Dic = Nothing
    Set Wb = Nothing
    Set Sht = Nothing
    Set oSht = Nothing
    Set OpenWb = Nothing
End Sub
Private Sub SetBorders(ByVal Rng As Range)
    With Rng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
Private Sub SetCenters(ByVal Rng As Range)
    With Rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        '.Columns.AutoFit
    End With
End Sub
'FilePath=FilePicker(InitialPath)
'If FilePath = "" Then Exit Sub
Function FilePicker(Optional InitialPath As String = "")
    Dim FilePath As String
    If InitialPath = "" Then
        InitialPath = Application.ActiveWorkbook.Path
    End If
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .InitialFileName = InitialPath
        .Title = "请选择单个Excel工作簿"
        .Filters.Clear
        .Filters.Add "Excel工作簿", "*.xls*"
        If .Show = -1 Then
            FilePath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件，本次汇总中断！"
        End If
    End With
    FilePicker = FilePath
End Function
Function WorkdaysInMonth(ByVal month As Date)
    Dim counter
    counter = 0
    firstday = CDate(Format(month, "yyyy/mm") & "/01")
    lastday = DateAdd("d", -1, CDate(Format(DateAdd("m", 1, month), "yyyy/mm") & "/01"))
    today = firstday
    Do
        If Weekday(today, vbFriday) <= 5 Then counter = counter + 1
        today = DateAdd("d", 1, today)
        If today = lastday Then Exit Do
    Loop
    WorkdaysInMonth = counter
End Function
Function WorkdaysBetween(ByVal firstday As Date, ByVal lastday As Date)
    Dim counter
    today = firstday
    Do
        If Weekday(today, vbFriday) <= 5 Then counter = counter + 1
        today = DateAdd("d", 1, today)
        If today = lastday Then Exit Do
    Loop
    WorkdaysBetween = counter
End Function
Function IsWorkday(ByVal OneDay As Date) As Boolean
       IsWorkday = (Weekday(OneDay, vbMonday) <= 5)
   '  ''debug.Print OneDay; " 是工作日  "; IsWorkday
End Function
Private Sub Sort_2003(ByVal Rng As Range, Optional WithHeader As Boolean = True)
    With Rng 'xlAscending
            .Sort _
            Key1:=Rng.Cells(1, 1), Order1:=xlAscending, _
            Header:=IIf(WithHeader, xlYes, xlNo), _
            MatchCase:=False, _
            Orientation:=xlTopToBottom, _
            SortMethod:=xlPinYin
    End With
End Sub

　　

Public Sub StepForward()
    Dim Dic As Object
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    
    Set Wb = Application.ThisWorkbook
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Sht = Wb.Worksheets("result")
    Set oSht = Wb.Worksheets("analyze")
    With Sht
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A3:M" & endrow)
        arr = Rng.Value
        
        For i = LBound(arr) To UBound(arr)
            Key = CStr(arr(i, 2))
            company = arr(i, 1)
            staff = arr(i, 3)
            
            IsSave = False
            
            If arr(i, 6) >= 1 Then
                debt = arr(i, 6)
                IsSave = True
            Else
                debt = ""
            End If
            
            If arr(i, 8) >= 3 Then
                late = arr(i, 8)
                 IsSave = True
            Else
                late = ""
            End If
            
            If arr(i, 10) >= 3 Then
                early = arr(i, 10)
                 IsSave = True
            Else
                early = ""
            End If
            
            If arr(i, 12) >= 3 Then
                forget = arr(i, 12)
                 IsSave = True
            Else
                forget = ""
            End If
            
           If IsSave Then Dic(Key) = Array(company, Key, staff, debt, late, early, forget)
            
        Next i
        
    End With
    
    
    With oSht
        .UsedRange.Offset(2).Clear
        Set Rng = .Range("A3")
        Set Rng = Rng.Resize(Dic.Count, 7)
        Rng.Value = Application.Rept(Dic.Items, 1)
        SetCenters .UsedRange
        SetBorders .UsedRange
        Sort_2003 Rng, False
        .Activate
        Rows("3:3").Select
        ActiveWindow.FreezePanes = True
    End With
    
    UsedTime = VBA.Timer - StartTime
    
    
    
End Sub
Private Sub SetBorders(ByVal Rng As Range)
    With Rng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
Private Sub SetCenters(ByVal Rng As Range)
    With Rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        '.Columns.AutoFit
    End With
End Sub
Private Sub Sort_2003(ByVal Rng As Range, Optional WithHeader As Boolean = True)
    With Rng 'xlAscending
            .Sort _
            Key1:=Rng.Cells(1, 1), Order1:=xlAscending, _
            Header:=IIf(WithHeader, xlYes, xlNo), _
            MatchCase:=False, _
            Orientation:=xlTopToBottom, _
            SortMethod:=xlPinYin
    End With
End Sub