fork download
  1. Option Explicit
  2. Dim dicT As Object '辞書 キー:支店名+課名+項目名(A~N) 値:粗利の値の合計値
  3. Const Sheet1 As String = "1部ピボット"
  4. Const Sheet2 As String = "2部ピボット"
  5. Const Sheet3 As String = "3部ピボット"
  6. Dim Uri_book As String '粗利データブック名
  7. Dim trg_mm As Long '指定月
  8. Dim Jis_folder As String '実績フォルダ
  9. Dim Kei_folder As String '計画フォルダ
  10. Dim trg_col As Long '算出カラム番号
  11. Dim warnP As String '警告データ
  12. Dim item_tbl1 As Variant '1部の項目名テーブル
  13. Dim item_tbl2 As Variant '2部の項目名テーブル
  14. Dim item_tbl3 As Variant '3部の項目名テーブル
  15. Public Sub 拠点別粗利集計()
  16. Dim ws As Worksheet
  17. Dim mm, ext As Variant
  18. Dim t1, t2 As Variant
  19. Dim Uri_path As String
  20. Dim key As Variant
  21. Set dicT = CreateObject("Scripting.Dictionary")
  22. Set ws = Worksheets("粗利集計")
  23. '項目名テーブル作成
  24. item_tbl1 = Array("I", "J", "K")
  25. item_tbl2 = Array("L", "M", "N")
  26. item_tbl3 = Array("A", "B", "C", "D", "E", "F", "G", "H")
  27. mm = ws.Cells(2, "A").Value '集計月
  28. If mm = "" Or IsNumeric(mm) = False Then
  29. MsgBox ("集計月が不正")
  30. Exit Sub
  31. End If
  32. trg_mm = mm
  33. If trg_mm < 1 Or trg_mm > 12 Then
  34. MsgBox ("集計月(1-12)が範囲外")
  35. Exit Sub
  36. End If
  37. '集計月に対応するカラム位置を取得
  38. trg_col = GetColNumber(trg_mm)
  39. Jis_folder = ws.Cells(2, "B").Value '実績フォルダ名
  40. Uri_book = ws.Cells(2, "C").Value '粗利データファイル
  41. '拡張子のチェック
  42. ext = Right(LCase(Uri_book), 5)
  43. If ext <> ".xlsx" And ext <> ".xlsm" Then
  44. MsgBox ("粗利データファイル名が不正")
  45. Exit Sub
  46. End If
  47. Kei_folder = ws.Cells(2, "D").Value '計画フォルダ名
  48.  
  49. If Dir(Jis_folder, vbDirectory) = "" Then
  50. MsgBox ("実績フォルダが存在しません<" & Jis_folder & ">")
  51. Exit Sub
  52. End If
  53. If Dir(Kei_folder, vbDirectory) = "" Then
  54. MsgBox ("計画フォルダが存在しません<" & Kei_folder & ">")
  55. Exit Sub
  56. End If
  57. '粗利データブック名設定
  58. Uri_path = Jis_folder & "\" & Uri_book
  59. If Dir(Uri_path, vbNormal) = "" Then
  60. MsgBox (Uri_path & "が存在しません")
  61. Exit Sub
  62. End If
  63.  
  64. If MsgBox(trg_mm & "月の粗利を" & Uri_book & "から集計します", vbOKCancel) <> vbOK Then Exit Sub
  65. t1 = Timer
  66. Application.ScreenUpdating = False
  67. '再計算を手動に設定
  68. Application.Calculation = xlCalculationManual
  69. '売上明細ブック名オープン
  70. Workbooks.Open Uri_path
  71. Workbooks(Uri_book).Activate
  72. 'ピボットデータ読み込み
  73. Call readPivot(Sheet1)
  74. Call readPivot(Sheet2)
  75. Call readPivot(Sheet3)
  76. '再計算を自動に戻す
  77. Application.Calculation = xlCalculationAutomatic
  78. Workbooks(Uri_book).Saved = True
  79. Workbooks(Uri_book).Close
  80. '計画フォルダ内の全ブックを更新する
  81. Call UpdateAllBooks(Kei_folder)
  82. Application.ScreenUpdating = True
  83. t2 = Timer
  84. MsgBox ("処理完了 所要時間(秒)=" & t2 - t1)
  85. warnP = ""
  86. '未処理のピボットがあるなら表示する
  87. If dicT.count > 0 Then
  88. For Each key In dicT
  89. warnP = warnP & key & vbLf
  90. Next
  91. End If
  92. If warnP <> "" Then
  93. MsgBox ("ピボットの以下の部門(支店)|所属(課)|項目名(A~N)のデータが未処理です" & vbLf & warnP)
  94. End If
  95. End Sub
  96.  
  97. '計画フォルダ内の全てのブックを更新する
  98. Private Sub UpdateAllBooks(ByVal Kei_folder As String)
  99. Dim bookname As String
  100. bookname = Dir(Kei_folder & "\*.xlsx", vbNormal)
  101. If bookname = "" Then
  102. MsgBox (Kei_folder & "内に拠点別ブックが存在しません。")
  103. End
  104. End If
  105. '全てのブックを更新する
  106. Do While bookname <> ""
  107. Call Update1Book(Kei_folder, bookname)
  108. bookname = Dir()
  109. Loop
  110. End Sub
  111.  
  112. '1つのブックを更新する
  113. Private Sub Update1Book(ByVal Kei_folder As String, ByVal bookname As String)
  114. Dim ws As Worksheet
  115. Dim i As Long
  116. Application.Calculation = xlCalculationManual
  117. Workbooks.Open Kei_folder & "\" & bookname
  118. Set ws = Worksheets("拠点計")
  119. Call Update1Sheet(bookname, ws)
  120. Application.Calculation = xlCalculationAutomatic
  121. 'ブックを保存し、閉じる
  122. Workbooks(bookname).Save
  123. Workbooks(bookname).Close
  124. End Sub
  125. '1つのシートを更新する
  126. Private Sub Update1Sheet(ByVal bookname As String, ByVal ws As Worksheet)
  127. '拠点シートに値を設定する
  128. '3部
  129. Call set_value(bookname, ws, "A", 9)
  130. Call set_value(bookname, ws, "B", 10)
  131. Call set_value(bookname, ws, "C", 11)
  132. Call set_value(bookname, ws, "D", 12)
  133. Call set_value(bookname, ws, "E", 13)
  134. Call set_value(bookname, ws, "F", 14)
  135. Call set_value(bookname, ws, "G", 15)
  136. Call set_value(bookname, ws, "H", 16)
  137. '1部
  138. Call set_value(bookname, ws, "I", 18)
  139. Call set_value(bookname, ws, "J", 19)
  140. Call set_value(bookname, ws, "K", 20)
  141. '2部
  142. Call set_value(bookname, ws, "L", 22)
  143. Call set_value(bookname, ws, "M", 23)
  144. Call set_value(bookname, ws, "N", 24)
  145. End Sub
  146. '個人シートに値の設定を行う
  147. Private Sub set_value(ByVal bookname As String, ByVal ws As Worksheet, ByVal item As String, ByVal row As Long)
  148. Dim col As Long
  149. Dim key As String
  150. 'カラム位置の設定
  151. col = trg_col
  152. key = ws.Cells(2, "C").Value & "|" & ws.Cells(3, "C").Value & "|" & item
  153. If dicT.exists(key) = True Then
  154. ws.Cells(row, col).Value = dicT(key)
  155. '登録したキーの削除
  156. dicT.Remove (key)
  157. Else
  158. '該当データなし
  159. ws.Cells(row, col).Value = ""
  160. End If
  161. End Sub
  162. 'ピボットテーブル読み込み
  163. Private Sub readPivot(ByVal sheet_name As String)
  164. Dim index As Long
  165. Dim sh As Worksheet
  166. Dim maxrow As Long
  167. Dim row As Long
  168. Dim dmonth As String
  169. Dim key As String
  170. Dim item As String
  171. Dim arari As Variant
  172. index = 0
  173. dmonth = trg_mm & "月"
  174. Set sh = Worksheets(sheet_name)
  175. maxrow = sh.Cells(Rows.count, "A").End(xlUp).row 'Sheet1 A列最大行
  176. '3行から最終行まで繰り返す
  177. For row = 3 To maxrow
  178. '集計月に一致するなら、テーブルに格納する
  179. If sh.Cells(row, "A").Text = dmonth Then
  180. Select Case sheet_name
  181. Case Sheet1
  182. Call get_arari1(sheet_name, sh, row, item, arari)
  183. Case Sheet2
  184. Call get_arari2(sheet_name, sh, row, item, arari)
  185. Case Sheet3
  186. Call get_arari3(sheet_name, sh, row, item, arari)
  187. End Select
  188. '支店名+課名+項目名
  189. key = sh.Cells(row, "D").Value & "|" & sh.Cells(row, "E").Value & "|" & item
  190. If dicT.exists(key) = False Then
  191. '最初のデータ
  192. dicT(key) = arari
  193. Else
  194. '以降のデータ
  195. dicT(key) = dicT(key) + arari
  196. End If
  197. End If
  198. Next
  199. End Sub
  200. '1部の粗利取得
  201. Private Sub get_arari1(ByVal sheet_name As String, ByVal sh As Worksheet, ByVal row As Long, ByRef item As String, ByRef arari As Variant)
  202. Dim ix As Long
  203. Call checkvalue1(sheet_name, sh, row, "K")
  204. arari = sh.Cells(row, "K").Value
  205. Call checkvalue2(sheet_name, sh, row, "F", 1, 2, False)
  206. Call checkvalue2(sheet_name, sh, row, "G", 1, 1, True)
  207. If sh.Cells(row, "G").Value = 1 Then
  208. ix = 2
  209. Else
  210. ix = sh.Cells(row, "F").Value - 1
  211. End If
  212. item = item_tbl1(ix)
  213. End Sub
  214. '2部の粗利取得
  215. Private Sub get_arari2(ByVal sheet_name As String, ByVal sh As Worksheet, ByVal row As Long, ByRef item As String, ByRef arari As Variant)
  216. Dim ix As Long
  217. Call checkvalue1(sheet_name, sh, row, "H")
  218. arari = sh.Cells(row, "H").Value
  219. Call checkvalue2(sheet_name, sh, row, "B", 4, 6, False)
  220. ix = sh.Cells(row, "B").Value - 4
  221. item = item_tbl2(ix)
  222. End Sub
  223. '3部の粗利取得
  224. Private Sub get_arari3(ByVal sheet_name As String, ByVal sh As Worksheet, ByVal row As Long, ByRef item As String, ByRef arari As Variant)
  225. Dim ix As Long
  226. Call checkvalue1(sheet_name, sh, row, "J")
  227. arari = sh.Cells(row, "J").Value
  228. Call checkvalue2(sheet_name, sh, row, "F", 1, 8, False)
  229. ix = sh.Cells(row, "F").Value - 1
  230. item = item_tbl3(ix)
  231. End Sub
  232. 'データのニューメリックチェックを行う
  233. Private Sub checkvalue1(ByVal sheet_name As String, ByVal sh As Worksheet, ByVal row As Long, ByVal col As String)
  234. If IsNumeric(sh.Cells(row, col).Value) = False Then
  235. sh.Activate
  236. sh.Cells(row, col).Select
  237. Application.Calculation = xlCalculationAutomatic
  238. MsgBox (sheet_name & "のデータ不正、以下の情報をメモしてください" & vbLf & row & "行" & col & "列")
  239. MsgBox (sh.Cells(row, col).Text)
  240. End
  241. End If
  242. End Sub
  243. 'データのニューメリックチェックを行い、範囲チェックを行う
  244. Private Sub checkvalue2(ByVal sheet_name As String, ByVal sh As Worksheet, ByVal row As Long, ByVal col As String, ByVal lowval As Long, ByVal highval As Long, ByVal allow_sp As Boolean)
  245. If allow_sp = True And sh.Cells(row, col).Value = "" Then
  246. Exit Sub
  247. End If
  248. Call checkvalue1(sheet_name, sh, row, col)
  249. If sh.Cells(row, col).Value > highval Or sh.Cells(row, col).Value < lowval Then
  250. sh.Activate
  251. sh.Cells(row, col).Select
  252. Application.Calculation = xlCalculationAutomatic
  253. MsgBox (sheet_name & "のデータ不正、以下の情報をメモしてください" & vbLf & row & "行" & col & "列")
  254. MsgBox (sh.Cells(row, col).Text)
  255. End
  256. End If
  257. End Sub
  258.  
  259. '指定月から指定月対応のカラム位置(実績の計)を計算する
  260. 'カラム位置は1からの連番
  261. '10月= 9... 9月=80
  262. Private Function GetColNumber(ByVal mm As Long)
  263. Dim ix As Long
  264. Dim arr As Variant
  265. '1月、2月、3月、4月、4月、5月、6月、7月、8月、9月、10月、11月、12月の先頭からの相対位置
  266. arr = Array(4, 5, 6, 9, 10, 11, 13, 14, 15, 0, 1, 2)
  267. ix = arr(mm - 1)
  268. GetColNumber = 3 + 6 * ix + 6
  269. End Function
  270.  
  271.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty