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. dicT(key1) = wrow + 2 '予測の行を設定
  117. End If
  118. Next
  119. check_out_sheet = True
  120. End Function
  121. '転記元の全シートを処理する
  122. Private Function read_all_sheets(ByRef wb1 As Workbook) As Boolean
  123. read_all_sheets = False
  124. Dim sarray As Variant
  125. Dim elm As Variant
  126. Dim result As Boolean
  127. '処理対象となるシートの一覧
  128. sarray = Array("D6110", "D6120", "D6125", "D6560")
  129. For Each elm In sarray
  130. If exist_sheet(wb1, elm) = True Then
  131. result = read_1_sheet(wb1, elm)
  132. If result = False Then Exit Function
  133. sheet_count = sheet_count + 1
  134. End If
  135. Next
  136. read_all_sheets = True
  137. End Function
  138. '指定シートがブック内にあるかチェックする
  139. Private Function exist_sheet(ByRef wb1, ByVal elm As String)
  140. Dim i As Long
  141. exist_sheet = False
  142. For i = 1 To wb1.Worksheets.Count
  143. If UCase(elm) = UCase(wb1.Worksheets(i).Name) Then
  144. exist_sheet = True
  145. Exit Function
  146. End If
  147. Next
  148. End Function
  149. '1シートを処理する
  150. Private Function read_1_sheet(ByRef wb1, ByVal elm As String)
  151. Dim ws As Worksheet
  152. Dim maxrow As Long
  153. Dim wrow As Long
  154. Dim wmonth As String
  155. Dim sname As String
  156. Dim t_mm As Long
  157. Dim k_mm As Long
  158. Dim tk_row As Long
  159. Dim t_col As Long
  160. Dim k_col As Long
  161. read_1_sheet = False
  162. Set ws = wb1.Worksheets(elm)
  163. maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
  164. For wrow = 2 To maxrow
  165. '投資月チェック
  166. wmonth = ws.Cells(wrow, "C").Value
  167. t_mm = get_month(wmonth)
  168. If t_mm = 0 Then
  169. ws.Activate
  170. ws.Cells(wrow, "C").Select
  171. MsgBox ("転記元シート[" & elm & "]投資月エラー:" & wmonth)
  172. Exit Function
  173. End If
  174. '計上月チェック
  175. wmonth = ws.Cells(wrow, "D").Value
  176. k_mm = get_month(wmonth)
  177. If k_mm = 0 Then
  178. ws.Activate
  179. ws.Cells(wrow, "D").Select
  180. MsgBox ("転記元シート[" & elm & "]計上月エラー:" & wmonth)
  181. Exit Function
  182. End If
  183. '装置名チェック
  184. sname = ws.Cells(wrow, "B").Value
  185. If dicT.exists(sname) = False Then
  186. sname = get_sname(ws.Cells(wrow, "A").Value)
  187. End If
  188. '転記先の装置名が存在する場合
  189. If sname <> "" Then
  190. tk_row = dicT(sname)
  191. t_col = get_column(t_mm)
  192. k_col = get_column(k_mm)
  193. ows1.Cells(tk_row, t_col).Value = ws.Cells(wrow, "E").Value '投資用金額
  194. ows2.Cells(tk_row, k_col).Value = ws.Cells(wrow, "E").Value '計上用金額
  195. data_count = data_count + 1
  196. End If
  197. Next
  198. read_1_sheet = True
  199. End Function
  200. '月の取得 yyyy/mm からmmの数値を取得(0はエラー)
  201. Private Function get_month(ByVal wmonth) As Long
  202. get_month = 0
  203. Dim w_mm As Long
  204. If RE.test(wmonth) = False Then Exit Function
  205. w_mm = CLng(Right(wmonth, 2))
  206. If w_mm < 1 Or w_mm > 12 Then Exit Function
  207. get_month = w_mm
  208. End Function
  209. '管理番号から転記先の装置名を取得する
  210. Private Function get_sname(ByVal kbango As String)
  211. Dim ptn As String
  212. Dim wrow As Long
  213. For wrow = 2 To k_maxrow1
  214. ptn = ks1.Cells(wrow, "A").Value
  215. If kbango Like ptn Then
  216. get_sname = ks1.Cells(wrow, "B").Value
  217. ks2.Cells(k_maxrow2, "A").Value = kbango
  218. ks2.Cells(k_maxrow2, "B").Value = ptn
  219. ks2.Cells(k_maxrow2, "C").Value = ks1.Cells(wrow, "B").Value
  220. k_maxrow2 = k_maxrow2 + 1
  221. Exit Function
  222. End If
  223. Next
  224. get_sname = ""
  225. End Function
  226. '月数からカラム番号を取得する
  227. Private Function get_column(ByVal mm As Long) As Long
  228. Dim bias As Long: bias = 8
  229. If mm < 4 Then mm = mm + 12
  230. If mm > 9 Then bias = bias + 1
  231. get_column = mm + bias
  232. End Function
  233.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty