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
