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 = 0
  86. For i = 0 To UBound(timeArr)
  87. val = timeArr(i)
  88. psn = 0
  89. If val > 0 Then
  90. psn = Count_Bit(val)
  91. If psn > 2 Then
  92. If sx = 0 Then
  93. sx = i
  94. ex = i
  95. Else
  96. If timeArr(sx) = val Then ex = i
  97. End If
  98. End If
  99. End If
  100. If sx <> 0 And timeArr(sx) <> timeArr(i) Then
  101. sh2.Cells(row2, "A").Value = Count_Bit(timeArr(sx)) '人数
  102. sh2.Cells(row2, "B").Value = DateAdd("d", sx \ 1440, start_day) '開始日
  103. sh2.Cells(row2, "C").Value = (sx Mod 1440) / 1440 '開始時間
  104. sh2.Cells(row2, "D").Value = DateAdd("d", ex \ 1440, start_day) '終了日
  105. sh2.Cells(row2, "E").Value = ((ex Mod 1440) + 1) / 1440 '終了時間
  106. sh2.Cells(row2, "F").Value = get_member(timeArr(sx)) '社員
  107. sx = 0
  108. ex = 0
  109. row2 = row2 + 1
  110. End If
  111. Next
  112. '中間データ降順ソート
  113. maxrow2 = row2 - 1
  114. If maxrow2 < 2 Then Exit Sub
  115. Dim rg As Range
  116. Set rg = sh2.Range("A2:F" & maxrow2)
  117. rg.Sort key1:=sh2.Range("A2"), order1:=xlDescending, Header:=xlNo
  118. '最終結果出力
  119. Dim oldpsn As Long: oldpsn = 0
  120. Dim dcount As Long
  121. Dim srow3 As Long
  122. Dim stime As Date
  123. Dim etime As Date
  124. Dim dtimes As Long
  125. Dim diff As Long
  126. For row2 = 2 To maxrow2
  127. psn = sh2.Cells(row2, "A").Value
  128. If psn <> oldpsn Then
  129. Call output_total(oldpsn, srow3, dcount, dtimes)
  130. srow3 = row3
  131. dcount = 0
  132. dtimes = 0
  133. End If
  134. dcount = dcount + 1
  135. sh3.Cells(row3, "D").Value = dcount '回数
  136. sh3.Cells(row3, "E").Value = sh2.Cells(row2, "B").Value '開始日付
  137. sh3.Cells(row3, "F").Value = sh2.Cells(row2, "C").Value '開始時刻
  138. sh3.Cells(row3, "G").Value = sh2.Cells(row2, "D").Value '終了日付
  139. sh3.Cells(row3, "H").Value = sh2.Cells(row2, "E").Value '終了時刻
  140. sh3.Cells(row3, "I").Value = sh2.Cells(row2, "F").Value '社員
  141.  
  142. stime = sh2.Cells(row2, "C").Value '開始時刻
  143. etime = sh2.Cells(row2, "E").Value '終了時刻
  144. diff = Hour(etime) * 60 + Minute(etime) - (Hour(stime) * 60 + Minute(stime))
  145. If diff < 0 Then diff = diff + 1440
  146. dtimes = dtimes + diff
  147. row3 = row3 + 1
  148. oldpsn = psn
  149. Next
  150. Call output_total(oldpsn, srow3, dcount, dtimes)
  151. MsgBox ("完了")
  152. End Sub
  153. '合計出力
  154. Private Sub output_total(ByVal oldpsn As Long, ByVal srow3 As Long, ByVal dcount As Long, ByVal dtimes_long As Long)
  155. If oldpsn = 0 Then Exit Sub
  156. sh3.Cells(srow3, "A").Value = oldpsn '人数
  157. sh3.Cells(srow3, "B").Value = dcount '年間回数
  158. sh3.Cells(srow3, "C").Value = dtimes_long / 1440 '年間時間
  159. End Sub
  160. 'エラー処理
  161. Private Sub data_error(ByVal wrow, ByVal msg)
  162. sh1.Activate
  163. sh1.Cells(wrow, "C").Select
  164. MsgBox (msg)
  165. End
  166. End Sub
  167. '社員名取得
  168. Private Function get_member(ByVal num As Long) As String
  169. Dim i As Long
  170. Dim obuf As String: obuf = ""
  171. Dim items As Variant
  172. Dim keys As Variant
  173. items = dicT.items
  174. keys = dicT.keys
  175. For i = 0 To dicT.Count - 1
  176. If (num And items(i)) <> 0 Then
  177. If obuf = "" Then
  178. obuf = keys(i)
  179. Else
  180. obuf = obuf & "," & keys(i)
  181. End If
  182. End If
  183. Next
  184. get_member = obuf
  185. End Function
  186. '時間テーブル初期化
  187. Private Sub init_data()
  188. Dim i As Long
  189. For i = 0 To UBound(timeArr)
  190. timeArr(i) = 0
  191. Next
  192. End Sub
  193. 'ビット数カウント
  194. Private Function Count_Bit(ByVal num As Long) As Long
  195. Dim pos As Long: pos = 1
  196. Dim i As Long
  197. Count_Bit = 0
  198. For i = 1 To MAXPSN
  199. If (num And pos) <> 0 Then Count_Bit = Count_Bit + 1
  200. pos = pos * 2
  201. Next
  202. End Function
  203.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty