fork download
  1. Option Explicit
  2.  
  3. Const Folder1 As String = "d:\goo\data10\IN" '転記元ブック格納フォルダ
  4. Const Folder2 As String = "d:\goo\data10\OUT" '転記先ブック格納フォルダ
  5. Const Book2 As String = "★【PGB】2024~2029年度 電源国内_PGB 投資予測_帳票"
  6. Dim RE As Object '正規表現オブジェクト
  7. Dim ks1 As Worksheet '管理シート
  8. Dim ks2 As Worksheet '変換結果シート
  9. Dim k_maxrow1 As Long '管理シート最大行番号
  10. Dim k_maxrow2 As Long '変換結果シート最大行番号
  11. Dim ows1 As Worksheet '投資用シート
  12. Dim ows2 As Worksheet '計上用シート
  13. Dim dicT As Object 'ディクショナリ キー:装置名 値:予測の行番号
  14. Dim book_count As Long '処理ブック件数
  15. Dim sheet_count As Long '処理シート件数
  16. Dim data_count As Long '処理データ件数
  17. Public Sub 月度対応転記()
  18. Dim krow1 As Long '管理シート行番号
  19. Dim sname As String '装置名称
  20. Dim bname As String
  21. Dim bname2 As String '転記先ブック名
  22. Dim bpath2 As String '転記先ブックのパス名
  23. Dim wb1 As Workbook '転記元ブック
  24. Dim wb2 As Workbook '転記先ブック
  25. Dim out_mm As Long '出力月数
  26. Application.ScreenUpdating = False
  27. book_count = 0
  28. sheet_count = 0
  29. data_count = 0
  30. Set dicT = CreateObject("Scripting.Dictionary")
  31. Set RE = CreateObject("VBScript.RegExp")
  32. RE.Pattern = "^\d{4}/\d{2}$"
  33. RE.Global = True
  34. Set ks1 = Worksheets("管理")
  35. Set ks2 = Worksheets("変換結果")
  36. out_mm = 0
  37. If IsNumeric(ks1.Range("E2").Value) = True Then
  38. out_mm = CLng(ks1.Range("E2").Value)
  39. End If
  40. If out_mm < 1 Or out_mm > 12 Then
  41. MsgBox ("管理シートの出力月が不正です")
  42. Exit Sub
  43. End If
  44. k_maxrow2 = 2
  45. '転記先ブックオープン
  46. bname2 = Book2 & ".xlsx"
  47. bpath2 = Folder2 & "\" & bname2
  48. Set wb2 = Workbooks.Open(bpath2)
  49. Set ows1 = wb2.Worksheets("国内_連結修正後")
  50. Set ows2 = wb2.Worksheets("国内_計上連結修正後")
  51. '投資用シート、計上用シート読込
  52. If check_out_sheet() = False Then Exit Sub
  53. '管理シート読込及び転記先名称のチェック
  54. k_maxrow1 = ks1.Cells(Rows.Count, "A").End(xlUp).Row
  55. For krow1 = 2 To k_maxrow1
  56. sname = ks1.Cells(krow1, "B").Value
  57. If dicT(sname) = False Then
  58. MsgBox ("管理シートの[" & sname & "]は転記先シートに存在しません")
  59. Exit Sub
  60. End If
  61. Next
  62.  
  63. '転記元ブックの読込
  64. bname = Dir(Folder1 & "\*.xlsx")
  65. Application.Calculation = xlCalculationManual
  66. Do While bname <> ""
  67. Set wb1 = Workbooks.Open(Folder1 & "\" & bname)
  68. If read_all_sheets(wb1) = False Then
  69. Application.Calculation = xlCalculationAutomatic
  70. Exit Sub
  71. End If
  72. wb1.Close
  73. book_count = book_count + 1
  74. bname = Dir()
  75. Loop
  76. '転記先ブックの名称を変えて保存する
  77. Application.Calculation = xlCalculationAutomatic
  78. bname2 = Book2 & "_" & out_mm & "月予測.xlsx"
  79. bpath2 = Folder2 & "\" & bname2
  80. Application.DisplayAlerts = False
  81. wb2.SaveAs (bpath2)
  82. Application.DisplayAlerts = True
  83. wb2.Close
  84. Application.ScreenUpdating = True
  85. MsgBox ("処理完了" & vbLf & "処理ブック件数=" & book_count & vbLf & "処理シート件数=" & sheet_count & vbLf & "処理データ件数=" & data_count)
  86. End Sub
  87. '転記先ブックのシートチェック
  88. Private Function check_out_sheet() As Boolean
  89. Dim eflag As Boolean: eflag = False
  90. Dim maxrow1 As Long
  91. Dim maxrow2 As Long
  92. check_out_sheet = False
  93. maxrow1 = ows1.Cells(Rows.Count, "J").End(xlUp).Row
  94. maxrow2 = ows2.Cells(Rows.Count, "J").End(xlUp).Row
  95. If maxrow1 <> maxrow2 Then
  96. MsgBox ("転記先ブックの2つのシートの行数が不一致です")
  97. Exit Function
  98. End If
  99. If maxrow1 < 14 Then eflag = True
  100. If (maxrow1 - 10) Mod 4 <> 0 Then eflag = True
  101. If eflag = True Then
  102. MsgBox ("転記先ブックの2つのシートの行数が正しくありません")
  103. Exit Function
  104. End If
  105. Dim wrow As Long
  106. Dim key1 As String
  107. Dim key2 As String
  108. For wrow = 7 To (maxrow1 - 4) Step 4
  109. key1 = ows1.Cells(wrow, "E").Value
  110. key2 = ows2.Cells(wrow, "E").Value
  111. If key1 <> key2 Then
  112. MsgBox ("転記先ブックの2つのシートの装置名の並びが不一致です")
  113. Exit Function
  114. End If
  115. If key1 <> "" Then
  116. '4月~9月を0クリア(予測、実績)
  117. ows1.Cells(wrow + 2, "L").Resize(2, 6).Value = 0
  118. ows2.Cells(wrow + 2, "L").Resize(2, 6).Value = 0
  119. '10月~3月を0クリア(予測、実績)
  120. ows1.Cells(wrow + 2, "S").Resize(2, 6).Value = 0
  121. ows2.Cells(wrow + 2, "S").Resize(2, 6).Value = 0
  122. dicT(key1) = wrow + 2 '予測の行を設定
  123. End If
  124. Next
  125. check_out_sheet = True
  126. End Function
  127. '転記元の全シートを処理する
  128. Private Function read_all_sheets(ByRef wb1 As Workbook) As Boolean
  129. read_all_sheets = False
  130. Dim sarray As Variant
  131. Dim elm As Variant
  132. Dim result As Boolean
  133. '処理対象となるシートの一覧
  134. sarray = Array("D6110", "D6120", "D6125", "D6560")
  135. For Each elm In sarray
  136. If exist_sheet(wb1, elm) = True Then
  137. result = read_1_sheet(wb1, elm)
  138. If result = False Then Exit Function
  139. sheet_count = sheet_count + 1
  140. End If
  141. Next
  142. read_all_sheets = True
  143. End Function
  144. '指定シートがブック内にあるかチェックする
  145. Private Function exist_sheet(ByRef wb1, ByVal elm As String)
  146. Dim i As Long
  147. exist_sheet = False
  148. For i = 1 To wb1.Worksheets.Count
  149. If UCase(elm) = UCase(wb1.Worksheets(i).Name) Then
  150. exist_sheet = True
  151. Exit Function
  152. End If
  153. Next
  154. End Function
  155. '1シートを処理する
  156. Private Function read_1_sheet(ByRef wb1, ByVal elm As String)
  157. Dim ws As Worksheet
  158. Dim maxrow As Long
  159. Dim wrow As Long
  160. Dim wmonth As String
  161. Dim sname As String
  162. Dim t_mm As Long
  163. Dim k_mm As Long
  164. Dim tk_row As Long
  165. Dim t_col As Long
  166. Dim k_col As Long
  167. read_1_sheet = False
  168. Set ws = wb1.Worksheets(elm)
  169. maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
  170. For wrow = 2 To maxrow
  171. '投資月チェック
  172. wmonth = ws.Cells(wrow, "C").Value
  173. t_mm = get_month(wmonth)
  174. If t_mm = 0 Then
  175. ws.Activate
  176. ws.Cells(wrow, "C").Select
  177. MsgBox ("転記元シート[" & elm & "]投資月エラー:" & wmonth)
  178. Exit Function
  179. End If
  180. '計上月チェック
  181. wmonth = ws.Cells(wrow, "D").Value
  182. k_mm = get_month(wmonth)
  183. If k_mm = 0 Then
  184. ws.Activate
  185. ws.Cells(wrow, "D").Select
  186. MsgBox ("転記元シート[" & elm & "]計上月エラー:" & wmonth)
  187. Exit Function
  188. End If
  189. '装置名チェック
  190. sname = ws.Cells(wrow, "B").Value
  191. If dicT.exists(sname) = False Then
  192. sname = get_sname(ws.Cells(wrow, "A").Value)
  193. End If
  194. '転記先の装置名が存在する場合
  195. If sname <> "" Then
  196. tk_row = dicT(sname)
  197. t_col = get_column(t_mm)
  198. k_col = get_column(k_mm)
  199. ows1.Cells(tk_row, t_col).Value = ws.Cells(wrow, "E").Value '投資用金額
  200. ows2.Cells(tk_row, k_col).Value = ws.Cells(wrow, "E").Value '計上用金額
  201. data_count = data_count + 1
  202. End If
  203. Next
  204. read_1_sheet = True
  205. End Function
  206. '月の取得 yyyy/mm からmmの数値を取得(0はエラー)
  207. Private Function get_month(ByVal wmonth) As Long
  208. get_month = 0
  209. Dim w_mm As Long
  210. If RE.test(wmonth) = False Then Exit Function
  211. w_mm = CLng(Right(wmonth, 2))
  212. If w_mm < 1 Or w_mm > 12 Then Exit Function
  213. get_month = w_mm
  214. End Function
  215. '管理番号から転記先の装置名を取得する
  216. Private Function get_sname(ByVal kbango As String)
  217. Dim ptn As String
  218. Dim wrow As Long
  219. For wrow = 2 To k_maxrow1
  220. ptn = ks1.Cells(wrow, "A").Value
  221. If kbango Like ptn Then
  222. get_sname = ks1.Cells(wrow, "B").Value
  223. ks2.Cells(k_maxrow2, "A").Value = kbango
  224. ks2.Cells(k_maxrow2, "B").Value = ptn
  225. ks2.Cells(k_maxrow2, "C").Value = ks1.Cells(wrow, "B").Value
  226. k_maxrow2 = k_maxrow2 + 1
  227. Exit Function
  228. End If
  229. Next
  230. get_sname = ""
  231. End Function
  232. '月数からカラム番号を取得する
  233. Private Function get_column(ByVal mm As Long) As Long
  234. Dim bias As Long: bias = 8
  235. If mm < 4 Then mm = mm + 12
  236. If mm > 9 Then bias = bias + 1
  237. get_column = mm + bias
  238. End Function
  239.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty