'久疏战阵 痛苦万分
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
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)
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) Then
'截取上下班时间
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
onDay = 0
lateTime = 0
earlyTime = 0
forgetTime = 0
forgetday = ""
lateday = ""
earlyday = ""
onDay = 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, lateTime, lateday, earlyTime, earlyday, forgetTime, forgetday)
Dic(Key) = ar
Else
ar = Dic(Key)
ar(4) = ar(4) + 1
'迟到判断
onLate = (DateDiff("s", CDate(ON_TIME), onTime) > 0)
onForget = (DateDiff("s", CDate(MID_TIME), onTime) > 0)
If onForget Then
ar(9) = ar(9) + 1
If ar(10) <> "" Then
ar(10) = ar(10) & vbCrLf & arr(i, 4) & "上午"
Else
ar(10) = arr(i, 4) & "上午"
End If
Else
If onLate Then
If duration < 510 Then
ar(5) = ar(5) + 1
If ar(6) = "" Then
ar(6) = arr(i, 4) & "上午"
Else
ar(6) = ar(6) & 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(9) = ar(9) + 1
If ar(10) <> "" Then
ar(10) = ar(10) & vbCrLf & arr(i, 4) & "下午"
Else
ar(10) = arr(i, 4) & "下午"
End If
Else
If offEarly 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
Dic(Key) = ar
End If
End If
End If
Next i
With osht
.UsedRange.Offset(2).Clear
Set Rng = .Range("A3")
Set Rng = Rng.Resize(Dic.Count, 11)
Rng.Value = Application.Rept(Dic.Items, 1)
SetCenters .UsedRange
SetBorders .UsedRange
.Activate
Rows("3:3").Select
ActiveWindow.FreezePanes = True
End With
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