fork download
  1. Option Explicit
  2. Const TRG_SHEET As String = "全体" '集計先シート名
  3. Const SRC_SHEET As String = "実績" '集計元シート名
  4. Const ROW_COUNT_OF_1BLOCK As Long = 28 '1ブロックの行数
  5. Const ROW_START_NO As Long = 6 'データの開始行
  6. Const ZENNEN As Long = 0 '前年
  7. Const TOUNEN As Long = 1 '当年
  8. Dim dicKCD As Object 'キー:分類区分コード 値:相対行番号(0オリジン)
  9. Dim dicRow As Object 'キー:開始行番号  値:true
  10. Dim dicT As Object 'キー:支店名+営業所名+課名 値:開始行番号
  11. Dim srowAllSum As Long '全体合計の開始行
  12. Dim UriArray As Variant '売上集計対象 分類コード(82、86、85、87、88)
  13. Public Sub 新全体集計()
  14. Dim maxrow As Long
  15. Dim i As Long
  16. Dim j As Long
  17. Dim wrow As Long
  18. Dim wcol As Long
  19. Dim srow As Long '開始行
  20. Dim scol As Long '開始列
  21. Dim siten As String '支店名
  22. Dim eigyosho As String '営業所
  23. Dim ka As String '課名
  24. Dim key As Variant 'キー
  25. Dim t1 As Variant
  26. Dim t2 As Variant
  27. Dim ksh As Worksheet '管理シート
  28. Dim tsh As Worksheet '全体シート
  29. Dim zen_folder As String '前年フォルダー
  30. Dim tou_folder As String '当年フォルダー
  31. Dim zen_file As String '前年実績ファイル
  32. Dim tou_file As String '当年実績ファイル
  33. Dim block_count As Long '全体シートのブロック数
  34. Set dicKCD = CreateObject("Scripting.Dictionary")
  35. Set dicT = CreateObject("Scripting.Dictionary")
  36. Set dicRow = CreateObject("Scripting.Dictionary")
  37. Set tsh = Worksheets(TRG_SHEET)
  38. Set ksh = Worksheets("管理")
  39. UriArray = Array("82", "85", "86", "87", "88") '売上を集計する分類コード
  40. '管理シートのチェック
  41. tou_folder = ksh.Range("B3").Value
  42. tou_file = ksh.Range("C3").Value
  43. Call check_folder("当年フォルダ", tou_folder)
  44. Call check_file("当年ファイル", tou_folder & "\" & tou_file)
  45. '全体シートのチェック
  46. maxrow = tsh.Cells(Rows.Count, "D").End(xlUp).row 'D列の最終行を求める
  47. If (maxrow - ROW_START_NO + 1) Mod ROW_COUNT_OF_1BLOCK <> 0 Then
  48. MsgBox ("全体シートの行数不正")
  49. Exit Sub
  50. End If
  51.  
  52. 'ブロック数算出
  53. block_count = (maxrow - ROW_START_NO + 1) \ ROW_COUNT_OF_1BLOCK
  54.  
  55. '分類区分コードのリストを作成する
  56. For wrow = ROW_START_NO To (ROW_COUNT_OF_1BLOCK + ROW_START_NO - 1)
  57. key = CStr(tsh.Cells(wrow, "E").Value)
  58. If key <> "" Then
  59. If dicKCD.exists(key) = False Then
  60. dicKCD(key) = wrow - ROW_START_NO '相対行を記憶
  61. Else
  62. MsgBox ("全体シートの分類区分コード重複")
  63. Exit Sub
  64. End If
  65. End If
  66. Next
  67. 'ブロック開始行番号記憶
  68. For i = 1 To block_count '1~最後のブロックまで処理
  69. srow = GetRowNumber(i)
  70. dicRow(srow) = True
  71. Next
  72.  
  73. '全体シートの支店名・営業所名・課名を記憶
  74. For wrow = ROW_START_NO To maxrow
  75. If tsh.Cells(wrow, "A").Value <> "" Then '支店名を取得
  76. siten = tsh.Cells(wrow, "A").Value
  77. End If
  78. If tsh.Cells(wrow, "B").Value <> "" Then '営業所名を取得
  79. eigyosho = tsh.Cells(wrow, "B").Value
  80. End If
  81. If tsh.Cells(wrow, "C").Value <> "" Then '課名を取得
  82. ka = tsh.Cells(wrow, "C").Value
  83. End If
  84. If siten = "全体合計" Then '全体合計の記憶
  85. key = "||||合計"
  86. If dicT.exists(key) = False Then
  87. Call store_row(key, wrow, siten, eigyosho, ka) '行番号チェック&記憶
  88. End If
  89. Else
  90. If Right(eigyosho, 2) = "合計" Then '支店合計の記憶
  91. key = siten & "|||合計"
  92. If dicT.exists(key) = False Then
  93. Call store_row(key, wrow, siten, eigyosho, ka) '行番号チェック&記憶
  94. End If
  95. Else
  96. If Right(ka, 2) = "合計" Then '営業所合計の記憶
  97. key = siten & "|" & eigyosho & "||合計"
  98. If dicT.exists(key) = False Then
  99. Call store_row(key, wrow, siten, eigyosho, ka) '行番号チェック&記憶
  100. End If
  101. End If
  102. End If
  103. End If
  104. key = siten & "|" & eigyosho & "|" & ka
  105. If dicT.exists(key) = False Then
  106. Call store_row(key, wrow, siten, eigyosho, ka) '行番号チェック&記憶
  107. End If
  108. Next
  109. key = "||||合計"
  110. If dicT.exists(key) = False Then
  111. MsgBox ("全体合計が全体シートになし")
  112. Exit Sub
  113. End If
  114. srowAllSum = dicT(key)
  115. If MsgBox("集計を開始します", vbOKCancel) <> vbOK Then
  116. Exit Sub
  117. End If
  118.  
  119. t1 = Timer
  120. Application.ScreenUpdating = False
  121. Application.Calculation = xlCalculationManual
  122. '全体シートクリア
  123. For i = 1 To block_count '1~最後のブロックまで処理
  124. srow = GetRowNumber(i)
  125. For j = 1 To 12 '1月~12月まで処理
  126. scol = GetColNumber(j)
  127. Call blockClear(tsh, srow, scol)
  128. Next
  129. Next
  130. '当年データを集計
  131. Call Sum1Book(tou_folder, tou_file, TOUNEN)
  132. Application.ScreenUpdating = True
  133. Application.Calculation = xlCalculationAutomatic
  134. t2 = Timer
  135. MsgBox ("処理完了 所要時間(秒)=" & t2 - t1)
  136. End Sub
  137. Private Sub check_folder(ByVal comment As String, ByVal path As String)
  138. If Dir(path, vbDirectory) = "" Then
  139. MsgBox (comment & "が不正[" & path & "]は存在しません")
  140. End
  141. End If
  142. End Sub
  143. Private Sub check_file(ByVal comment As String, ByVal path As String)
  144. If Dir(path, vbNormal) = "" Then
  145. MsgBox (comment & "が不正[" & path & "]は存在しません")
  146. End
  147. End If
  148. End Sub
  149. '行番号チェック&記憶
  150. Private Sub store_row(ByVal key As Variant, ByVal wrow As Long, ByVal siten As String, ByVal eigyosho As String, ByVal ka As String)
  151. If dicRow.exists(wrow) = False Then
  152. MsgBox ("開始行不正 行番号=" & wrow & " 支店=" & siten & " 営業所=" & eigyosho & " 課=" & ka)
  153. End
  154. End If
  155. dicT(key) = wrow
  156. End Sub
  157. '1つのブックを集計する
  158. Private Sub Sum1Book(ByVal src_folder As String, ByVal bookname As String, ByVal nendo As Long)
  159. Workbooks.Open src_folder & "\" & bookname
  160. Call Sum1Sheet(nendo)
  161. 'ブックを保存しないで閉じる(更新していないので保存不要)
  162. Workbooks(bookname).Saved = True
  163. Workbooks(bookname).Close
  164. End Sub
  165. '1つのシートを集計する
  166. Private Sub Sum1Sheet(ByVal nendo As Long)
  167. Dim ws As Worksheet
  168. Dim maxrow As Long
  169. Dim wrow As Long
  170. Dim wcol As String
  171. Dim mm As Long '月
  172. Dim siten As String '支店
  173. Dim eigyosho As String '営業所
  174. Dim ka As String '課
  175. Dim key As Variant '支店・課のキー
  176. Dim key2 As Variant '支店・営業所合計のキー
  177. Dim key3 As Variant '支店合計のキー
  178. Dim bcd As String '分類区分コード
  179. Dim val1 As Variant 'H列/I列の値
  180. Dim val2 As Variant 'J列の値
  181. Dim rowA As Long '全体シートの行
  182. Dim rowX As Long '全体シートの支店・営業所合計の行
  183. Dim rowY As Long '全体シートの支店合計の行
  184. Dim rowZ As Long '全体シートの全体合計の行
  185. Dim scol As Long '全体シートの対応月の開始列
  186.  
  187. Set ws = Worksheets(SRC_SHEET)
  188. maxrow = ws.Cells(Rows.Count, "A").End(xlUp).row 'A列の最終行を求める
  189. For wrow = 3 To maxrow
  190. mm = get_month(ws.Cells(wrow, "A").Text)
  191. If mm = -1 Then
  192. Call abort_proc(nendo, wrow, "A", "売上日付不正(" & ws.Cells(wrow, "A").Text & ")")
  193. End If
  194. siten = ws.Cells(wrow, "B").Value '支店名取得
  195. eigyosho = ws.Cells(wrow, "C").Value '営業所取得
  196. ka = ws.Cells(wrow, "D").Value '課名取得
  197. key = siten & "|" & eigyosho & "|" & ka
  198. If dicT.exists(key) = False Then
  199. Call abort_proc(nendo, wrow, "B", "支店・営業所・課が全体シートに未登録(" & key & ")")
  200. End If
  201. key2 = siten & "|" & eigyosho & "||合計"
  202. key3 = siten & "|||合計"
  203. bcd = ws.Cells(wrow, "G").Value '分類区分コード取得
  204. If dicKCD.exists(bcd) = False Then
  205. Call abort_proc(nendo, wrow, "G", "分類区分コードが全体シートに未登録(" & bcd & ")")
  206. End If
  207. If is_uriage(bcd) = True Then
  208. wcol = "J"
  209. Else
  210. wcol = "I"
  211. End If
  212. val1 = get_val(nendo, ws, wrow, wcol)
  213. val2 = get_val(nendo, ws, wrow, "K")
  214. rowA = dicT(key) + dicKCD(bcd)
  215. If dicT.exists(key2) = True Then
  216. rowX = dicT(key2) + dicKCD(bcd)
  217. Else
  218. rowX = 0
  219. End If
  220. If dicT.exists(key3) = True Then
  221. rowY = dicT(key3) + dicKCD(bcd)
  222. Else
  223. rowY = 0
  224. End If
  225. rowZ = srowAllSum + dicKCD(bcd)
  226. scol = GetColNumber(mm)
  227. '数量/価格の集計
  228. Call add_val(nendo, rowA, scol + 3, val1)
  229. Call add_val(nendo, rowX, scol + 3, val1)
  230. Call add_val(nendo, rowY, scol + 3, val1)
  231. Call add_val(nendo, rowZ, scol + 3, val1)
  232. '粗利の集計
  233. Call add_val(nendo, rowA, scol + 8, val2)
  234. Call add_val(nendo, rowX, scol + 8, val2)
  235. Call add_val(nendo, rowY, scol + 8, val2)
  236. Call add_val(nendo, rowZ, scol + 8, val2)
  237. Next
  238. End Sub
  239. '全体シートへ加算する
  240. Private Sub add_val(ByVal nendo As Long, ByVal wrow As Long, ByVal wcol As Long, ByVal val As Variant)
  241. If wrow = 0 Then Exit Sub
  242. If val = "" Then Exit Sub
  243. If nendo = TOUNEN Then wcol = wcol + 1
  244. ThisWorkbook.Worksheets(TRG_SHEET).Cells(wrow, wcol).Value = ThisWorkbook.Worksheets(TRG_SHEET).Cells(wrow, wcol).Value + val
  245. End Sub
  246. '分類区分コードが売上の集計か否かを返す
  247. 'true:売上の集計
  248. 'false:数量の集計
  249. Private Function is_uriage(ByVal bcd As String) As Boolean
  250. Dim i As Long
  251. is_uriage = True
  252. For i = 0 To UBound(UriArray)
  253. If UriArray(i) = bcd Then Exit Function
  254. Next
  255. is_uriage = False
  256. End Function
  257. '文字で表示された月(1月...12月)の月を取得する
  258. Private Function get_month(ByVal mstr As String) As Long
  259. Dim mm As String
  260. get_month = -1
  261. If Right(mstr, 1) <> "月" Then Exit Function
  262. mm = Left(mstr, Len(mstr) - 1)
  263. If IsNumeric(mm) = False Then Exit Function
  264. get_month = CLng(mm)
  265. If get_month > 0 And get_month < 13 Then Exit Function
  266. get_month = -1
  267. End Function
  268. '指定行、指定列のデータの取得及びチェック
  269. Private Function get_val(ByVal nendo As String, ByVal ws As Worksheet, ByVal wrow As Long, ByVal wcol As String) As Variant
  270. get_val = ws.Cells(wrow, wcol).Value
  271. If IsNumeric(get_val) = False Then
  272. Call abort_proc(nendo, wrow, wcol, " 列=" & wcol & " 不正データ(" & ws.Cells(wrow, wcol).Text & ")")
  273. End If
  274. End Function
  275. 'マクロ停止処理
  276. Private Sub abort_proc(ByVal nendo As Long, ByVal wrow As Long, ByVal wcol As Variant, ByVal msg As String)
  277. Dim name As String
  278. If nendo = ZENNEN Then
  279. name = "前年元データ"
  280. Else
  281. name = "当年元データ"
  282. End If
  283. MsgBox (name & " 行番号=" & wrow & " " & msg)
  284. Worksheets(SRC_SHEET).Activate
  285. Cells(wrow, wcol).Select
  286. Application.Calculation = xlCalculationAutomatic
  287. End
  288. End Sub
  289. 'ブロッククリア(1課・1ケ月分)
  290. Private Sub blockClear(ByVal ws As Worksheet, ByVal srow As Long, ByVal scol As Long)
  291. Dim wrow As Long
  292. Dim key As Variant
  293. For Each key In dicKCD
  294. wrow = dicKCD(key) + srow
  295. ws.Cells(wrow, scol + 4).Value = "" '実績・当年数量
  296. ws.Cells(wrow, scol + 9).Value = "" '実績・当年粗利
  297. Next
  298. End Sub
  299. '指定月から指定月対応のカラム位置(計画数量)を計算する
  300. 'カラム位置は1からの連番
  301. '10月=6 ... 9月=186
  302. Private Function GetColNumber(ByVal mm As Long)
  303. Dim x, ix As Long
  304. If mm < 10 Then mm = mm + 12
  305. x = mm - 10
  306. ix = x + x \ 3 + x \ 6
  307. GetColNumber = 7 + 12 * ix
  308. End Function
  309.  
  310. '指定ブロック番号の行番号を取得する
  311. '1=6,2=34,21=566
  312. Private Function GetRowNumber(ByVal blkNo As Long)
  313. GetRowNumber = ROW_START_NO + (blkNo - 1) * ROW_COUNT_OF_1BLOCK
  314. End Function
  315.  
  316. '列番号を英文字に変換
  317. Function ConvertToLetter(ByVal iCol As Integer) As String
  318. Dim iAlpha As Integer
  319. Dim iRemainder As Integer
  320. iAlpha = Int((iCol - 1) / 26)
  321. iRemainder = iCol - (iAlpha * 26)
  322. If iAlpha > 0 Then
  323. ConvertToLetter = Chr(iAlpha + 64)
  324. End If
  325. If iRemainder > 0 Then
  326. ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
  327. End If
  328. End Function
  329.  
  330.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty