Option Explicit
Const MAXARR As Long = 24 * 60 * 367& '作業時間テーブルの要素数(1年分)
Const MAXPSN As Long = 5 '最大社員数
Dim dicT As Object '社員名の連想配列 キー:社員名
'値:1,2,4,8,16,32(1=社員1,2=社員2,4=社員3,8=社員4,16=社員5)
Dim timeArr(MAXARR) As Long '作業時間テーブル
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Public Sub 重複時間算出()
Set sh1 = Worksheets("元データ")
Set sh2 = Worksheets("中間データ")
Set sh3 = Worksheets("集計データ")
Dim bit_pos As Long: bit_pos = 1
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row2 As Long
Dim row3 As Long
Dim name As String
Set dicT = CreateObject("Scripting.Dictionary") '連想配列の定義
maxrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row '最大行取得
If maxrow1 < 2 Then Exit Sub
For row1 = 2 To maxrow1
name = sh1.Cells(row1, "B").Value
If dicT.exists(name) = False Then
dicT(name) = bit_pos
bit_pos = bit_pos * 2
End If
Next
If dicT.Count > MAXPSN Then
MsgBox ("社員数が多すぎます")
End If
Dim start_year As Long '年(元データ2行目)
Dim start_day As Date '上記年の1月1日
Dim sdate As Date
Dim edate As Date
Dim sx As Long
Dim ex As Long
Dim srd As Long
Dim erd As Long
Dim val As Long
Dim psn As Long
Dim i As Long
Call init_data
start_year = Year(sh1.Cells(2, "C").Value)
start_day = DateSerial(start_year, 1, 1)
'元データ読み込み
For row1 = 2 To maxrow1
name = sh1.Cells(row1, "B").Value
sdate = sh1.Cells(row1, "C").Value
edate = sh1.Cells(row1, "D").Value
If Year(sdate) <> start_year Then
Call data_error(row1, "年が不一致")
End If
If sdate >= edate Then
Call data_error(row1, "開始時間と終了時間の順序不正")
End If
If edate - sdate >= 1# Then
Call data_error(row1, "24時間以上の勤務")
End If
srd = DateDiff("d", start_day, sdate)
erd = DateDiff("d", start_day, edate)
sx = srd * 1440 + Hour(sdate) * 60 + Minute(sdate)
ex = erd * 1440 + Hour(edate) * 60 + Minute(edate)
For i = sx To ex - 1
timeArr(i) = timeArr(i) Or dicT(name)
Next
Next
sh2.Rows("2:" & Rows.Count).ClearContents
sh3.Rows("3:" & Rows.Count).ClearContents
sh2.Columns("B:B").NumberFormatLocal = "yyyy/m/d"
sh2.Columns("D:D").NumberFormatLocal = "yyyy/m/d"
sh2.Columns("C:C").NumberFormatLocal = "h:mm"
sh2.Columns("E:E").NumberFormatLocal = "h:mm"
sh3.Columns("C:C").NumberFormatLocal = "[h]:mm"
sh3.Columns("E:E").NumberFormatLocal = "yyyy/m/d"
sh3.Columns("F:F").NumberFormatLocal = "h:mm"
sh3.Columns("G:G").NumberFormatLocal = "yyyy/m/d"
sh3.Columns("H:H").NumberFormatLocal = "h:mm"
row2 = 2
row3 = 3
'中間データ出力
sx = -1
For i = 0 To UBound(timeArr)
If sx <> -1 Then
If timeArr(sx) <> timeArr(i) Then
sh2.Cells(row2, "A").Value = Count_Bit(timeArr(sx)) '人数
sh2.Cells(row2, "B").Value = DateAdd("d", sx \ 1440, start_day) '開始日
sh2.Cells(row2, "C").Value = (sx Mod 1440) / 1440 '開始時間
sh2.Cells(row2, "D").Value = DateAdd("d", ex \ 1440, start_day) '終了日
sh2.Cells(row2, "E").Value = ((ex Mod 1440) + 1) / 1440 '終了時間
sh2.Cells(row2, "F").Value = get_member(timeArr(sx)) '社員
sx = -1
ex = -1
row2 = row2 + 1
Else
ex = i
End If
End If
val = timeArr(i)
If sx = -1 Then
If val > 0 Then
psn = Count_Bit(val)
If psn > 2 Then
sx = i
ex = i
End If
End If
End If
Next
'中間データ降順ソート
maxrow2 = row2 - 1
If maxrow2 < 2 Then Exit Sub
Dim rg As Range
Set rg = sh2.Range("A2:F" & maxrow2)
rg.Sort key1:=sh2.Range("A2"), order1:=xlDescending, Header:=xlNo
'最終結果出力
Dim oldpsn As Long: oldpsn = 0
Dim dcount As Long
Dim srow3 As Long
Dim stime As Date
Dim etime As Date
Dim dtimes As Long
Dim diff As Long
For row2 = 2 To maxrow2
psn = sh2.Cells(row2, "A").Value
If psn <> oldpsn Then
Call output_total(oldpsn, srow3, dcount, dtimes)
srow3 = row3
dcount = 0
dtimes = 0
End If
dcount = dcount + 1
sh3.Cells(row3, "D").Value = dcount '回数
sh3.Cells(row3, "E").Value = sh2.Cells(row2, "B").Value '開始日付
sh3.Cells(row3, "F").Value = sh2.Cells(row2, "C").Value '開始時刻
sh3.Cells(row3, "G").Value = sh2.Cells(row2, "D").Value '終了日付
sh3.Cells(row3, "H").Value = sh2.Cells(row2, "E").Value '終了時刻
sh3.Cells(row3, "I").Value = sh2.Cells(row2, "F").Value '社員
stime = sh2.Cells(row2, "C").Value '開始時刻
etime = sh2.Cells(row2, "E").Value '終了時刻
diff = Hour(etime) * 60 + Minute(etime) - (Hour(stime) * 60 + Minute(stime))
If diff < 0 Then diff = diff + 1440
dtimes = dtimes + diff
row3 = row3 + 1
oldpsn = psn
Next
Call output_total(oldpsn, srow3, dcount, dtimes)
MsgBox ("完了")
End Sub
'合計出力
Private Sub output_total(ByVal oldpsn As Long, ByVal srow3 As Long, ByVal dcount As Long, ByVal dtimes_long As Long)
If oldpsn = 0 Then Exit Sub
sh3.Cells(srow3, "A").Value = oldpsn '人数
sh3.Cells(srow3, "B").Value = dcount '年間回数
sh3.Cells(srow3, "C").Value = dtimes_long / 1440 '年間時間
End Sub
'エラー処理
Private Sub data_error(ByVal wrow, ByVal msg)
sh1.Activate
sh1.Cells(wrow, "C").Select
MsgBox (msg)
End
End Sub
'社員名取得
Private Function get_member(ByVal num As Long) As String
Dim i As Long
Dim obuf As String: obuf = ""
Dim items As Variant
Dim keys As Variant
items = dicT.items
keys = dicT.keys
For i = 0 To dicT.Count - 1
If (num And items(i)) <> 0 Then
If obuf = "" Then
obuf = keys(i)
Else
obuf = obuf & "," & keys(i)
End If
End If
Next
get_member = obuf
End Function
'時間テーブル初期化
Private Sub init_data()
Dim i As Long
For i = 0 To UBound(timeArr)
timeArr(i) = 0
Next
End Sub
'ビット数カウント
Private Function Count_Bit(ByVal num As Long) As Long
Dim pos As Long: pos = 1
Dim i As Long
Count_Bit = 0
For i = 1 To MAXPSN
If (num And pos) <> 0 Then Count_Bit = Count_Bit + 1
pos = pos * 2
Next
End Function