fork download
  1. Option Explicit
  2. Const MAXARR As Long = 24 * 60 * 367& '作業時間テーブルの要素数(1年分)
  3. Const MAXPSN As Long = 5 '最大社員数
  4. Dim dicT As Object '社員名の連想配列 キー:社員名
  5. '値:1,2,4,8,16,32(1=社員1,2=社員2,4=社員3,8=社員4,16=社員5)
  6. Dim timeArr(MAXARR) As Long '作業時間テーブル
  7. Dim sh1 As Worksheet
  8. Dim sh2 As Worksheet
  9. Dim sh3 As Worksheet
  10.  
  11. Public Sub 重複時間算出()
  12. Set sh1 = Worksheets("元データ")
  13. Set sh2 = Worksheets("中間データ")
  14. Set sh3 = Worksheets("集計データ")
  15. Dim bit_pos As Long: bit_pos = 1
  16. Dim maxrow1 As Long
  17. Dim maxrow2 As Long
  18. Dim row1 As Long
  19. Dim row2 As Long
  20. Dim row3 As Long
  21. Dim name As String
  22. Set dicT = CreateObject("Scripting.Dictionary") '連想配列の定義
  23. maxrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row '最大行取得
  24. If maxrow1 < 2 Then Exit Sub
  25. For row1 = 2 To maxrow1
  26. name = sh1.Cells(row1, "B").Value
  27. If dicT.exists(name) = False Then
  28. dicT(name) = bit_pos
  29. bit_pos = bit_pos * 2
  30. End If
  31. Next
  32. If dicT.Count > MAXPSN Then
  33. MsgBox ("社員数が多すぎます")
  34. End If
  35. Dim start_year As Long '年(元データ2行目)
  36. Dim start_day As Date '上記年の1月1日
  37. Dim sdate As Date
  38. Dim edate As Date
  39. Dim sx As Long
  40. Dim ex As Long
  41. Dim srd As Long
  42. Dim erd As Long
  43. Dim val As Long
  44. Dim psn As Long
  45. Dim i As Long
  46. Call init_data
  47. start_year = Year(sh1.Cells(2, "C").Value)
  48. start_day = DateSerial(start_year, 1, 1)
  49. '元データ読み込み
  50. For row1 = 2 To maxrow1
  51. name = sh1.Cells(row1, "B").Value
  52. sdate = sh1.Cells(row1, "C").Value
  53. edate = sh1.Cells(row1, "D").Value
  54. If Year(sdate) <> start_year Then
  55. Call data_error(row1, "年が不一致")
  56. End If
  57. If sdate >= edate Then
  58. Call data_error(row1, "開始時間と終了時間の順序不正")
  59. End If
  60. If edate - sdate >= 1# Then
  61. Call data_error(row1, "24時間以上の勤務")
  62. End If
  63. srd = DateDiff("d", start_day, sdate)
  64. erd = DateDiff("d", start_day, edate)
  65. sx = srd * 1440 + Hour(sdate) * 60 + Minute(sdate)
  66. ex = erd * 1440 + Hour(edate) * 60 + Minute(edate)
  67. For i = sx To ex - 1
  68. timeArr(i) = timeArr(i) Or dicT(name)
  69. Next
  70. Next
  71. sh2.Rows("2:" & Rows.Count).ClearContents
  72. sh3.Rows("3:" & Rows.Count).ClearContents
  73. sh2.Columns("B:B").NumberFormatLocal = "yyyy/m/d"
  74. sh2.Columns("D:D").NumberFormatLocal = "yyyy/m/d"
  75. sh2.Columns("C:C").NumberFormatLocal = "h:mm"
  76. sh2.Columns("E:E").NumberFormatLocal = "h:mm"
  77. sh3.Columns("C:C").NumberFormatLocal = "[h]:mm"
  78. sh3.Columns("E:E").NumberFormatLocal = "yyyy/m/d"
  79. sh3.Columns("F:F").NumberFormatLocal = "h:mm"
  80. sh3.Columns("G:G").NumberFormatLocal = "yyyy/m/d"
  81. sh3.Columns("H:H").NumberFormatLocal = "h:mm"
  82. row2 = 2
  83. row3 = 3
  84. '中間データ出力
  85. sx = -1
  86. For i = 0 To UBound(timeArr)
  87. If sx <> -1 Then
  88. If timeArr(sx) <> timeArr(i) Then
  89. sh2.Cells(row2, "A").Value = Count_Bit(timeArr(sx)) '人数
  90. sh2.Cells(row2, "B").Value = DateAdd("d", sx \ 1440, start_day) '開始日
  91. sh2.Cells(row2, "C").Value = (sx Mod 1440) / 1440 '開始時間
  92. sh2.Cells(row2, "D").Value = DateAdd("d", ex \ 1440, start_day) '終了日
  93. sh2.Cells(row2, "E").Value = ((ex Mod 1440) + 1) / 1440 '終了時間
  94. sh2.Cells(row2, "F").Value = get_member(timeArr(sx)) '社員
  95. sx = -1
  96. ex = -1
  97. row2 = row2 + 1
  98. Else
  99. ex = i
  100. End If
  101. End If
  102. val = timeArr(i)
  103. If sx = -1 Then
  104. If val > 0 Then
  105. psn = Count_Bit(val)
  106. If psn > 2 Then
  107. sx = i
  108. ex = i
  109. End If
  110. End If
  111. End If
  112. Next
  113. '中間データ降順ソート
  114. maxrow2 = row2 - 1
  115. If maxrow2 < 2 Then Exit Sub
  116. Dim rg As Range
  117. Set rg = sh2.Range("A2:F" & maxrow2)
  118. rg.Sort key1:=sh2.Range("A2"), order1:=xlDescending, Header:=xlNo
  119. '最終結果出力
  120. Dim oldpsn As Long: oldpsn = 0
  121. Dim dcount As Long
  122. Dim srow3 As Long
  123. Dim stime As Date
  124. Dim etime As Date
  125. Dim dtimes As Long
  126. Dim diff As Long
  127. For row2 = 2 To maxrow2
  128. psn = sh2.Cells(row2, "A").Value
  129. If psn <> oldpsn Then
  130. Call output_total(oldpsn, srow3, dcount, dtimes)
  131. srow3 = row3
  132. dcount = 0
  133. dtimes = 0
  134. End If
  135. dcount = dcount + 1
  136. sh3.Cells(row3, "D").Value = dcount '回数
  137. sh3.Cells(row3, "E").Value = sh2.Cells(row2, "B").Value '開始日付
  138. sh3.Cells(row3, "F").Value = sh2.Cells(row2, "C").Value '開始時刻
  139. sh3.Cells(row3, "G").Value = sh2.Cells(row2, "D").Value '終了日付
  140. sh3.Cells(row3, "H").Value = sh2.Cells(row2, "E").Value '終了時刻
  141. sh3.Cells(row3, "I").Value = sh2.Cells(row2, "F").Value '社員
  142.  
  143. stime = sh2.Cells(row2, "C").Value '開始時刻
  144. etime = sh2.Cells(row2, "E").Value '終了時刻
  145. diff = Hour(etime) * 60 + Minute(etime) - (Hour(stime) * 60 + Minute(stime))
  146. If diff < 0 Then diff = diff + 1440
  147. dtimes = dtimes + diff
  148. row3 = row3 + 1
  149. oldpsn = psn
  150. Next
  151. Call output_total(oldpsn, srow3, dcount, dtimes)
  152. MsgBox ("完了")
  153. End Sub
  154. '合計出力
  155. Private Sub output_total(ByVal oldpsn As Long, ByVal srow3 As Long, ByVal dcount As Long, ByVal dtimes_long As Long)
  156. If oldpsn = 0 Then Exit Sub
  157. sh3.Cells(srow3, "A").Value = oldpsn '人数
  158. sh3.Cells(srow3, "B").Value = dcount '年間回数
  159. sh3.Cells(srow3, "C").Value = dtimes_long / 1440 '年間時間
  160. End Sub
  161. 'エラー処理
  162. Private Sub data_error(ByVal wrow, ByVal msg)
  163. sh1.Activate
  164. sh1.Cells(wrow, "C").Select
  165. MsgBox (msg)
  166. End
  167. End Sub
  168. '社員名取得
  169. Private Function get_member(ByVal num As Long) As String
  170. Dim i As Long
  171. Dim obuf As String: obuf = ""
  172. Dim items As Variant
  173. Dim keys As Variant
  174. items = dicT.items
  175. keys = dicT.keys
  176. For i = 0 To dicT.Count - 1
  177. If (num And items(i)) <> 0 Then
  178. If obuf = "" Then
  179. obuf = keys(i)
  180. Else
  181. obuf = obuf & "," & keys(i)
  182. End If
  183. End If
  184. Next
  185. get_member = obuf
  186. End Function
  187. '時間テーブル初期化
  188. Private Sub init_data()
  189. Dim i As Long
  190. For i = 0 To UBound(timeArr)
  191. timeArr(i) = 0
  192. Next
  193. End Sub
  194. 'ビット数カウント
  195. Private Function Count_Bit(ByVal num As Long) As Long
  196. Dim pos As Long: pos = 1
  197. Dim i As Long
  198. Count_Bit = 0
  199. For i = 1 To MAXPSN
  200. If (num And pos) <> 0 Then Count_Bit = Count_Bit + 1
  201. pos = pos * 2
  202. Next
  203. End Function
  204.  
  205.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty