■社内DXの依頼内容
・2つのインプットファイルがあり、その中の複数シートのデータを、1つのアウトプットファイル、1シートに集約しXLSファイルとして出力したい
・処理漏れや誤処理厳禁のため、処理後に処理漏れ確認および誤処理検知できるような仕様としたい
■社内DXの条件
１．2つのインプットファイル（A社ファイル，B社ファイル）は、2シート目から順に転記
２．インプットファイル、“対象期間（前）”と“対象期間（後）”の月数が、12か月以内のものは、そのまま転記し、13か月以上のものは"1月～12月”の表示形式で最大12か月の期間で行を分ける。（1行の内、期間は年を跨がない）
（例）「対象期間（前）：2021年5月」「対象期間（後）：2023年3月」の場合
| 対象期間（前） | 対象期間（後） |
| 1行目 | 2021 | 5 | 2021 | 12 |
| 2行目 | 2022 | 1 | 2022 | 12 |
| 3行目 | 2023 | 1 | 2023 | 3 |
３．ファイルパス、ファイル数、ファイル名は固定（拡張子は.xlsx or .xls）。
４．シート数、シート名は変動有り（データ記載は2シート目～は固定）
■諸元
・インプットファイルを開く
・2シート目からの情報を取得する
・対象期間（前）と対象期間（後）の期間が12か月以内かどうか判断し、転記する
なお13か月以上の場合は年単位で分割し転記する
・転記は検証用シート「処理結果」とアウトプット用シート「output」にそれぞれ転記することとし、「処理結果」で処理漏れがないか確認できるようにする
・アウトプット用シート「output」を新規ブックにコピーし.xls形式にて保存する
■作成方法
１．2シート目からデータのある２つのファイルを準備する。
なおデータの配置は以下とします。
・A～D列：番号
・E列 ：氏名
・F列 ：対象期間(前)の年
・G列 ：対象期間(前)の月
・H列 ：対象期間(後)の年
・I列 ：対象期間(後)の月
２．実際にマクロを書いていく
Sub Main()
Dim strFP As String '/--フォルダパス--/'
Dim strFN As String '/--ファイル名--/'
Dim mWB As Workbook '/--マクロのワークブック--/'
Dim iWB As Workbook '/--インプットファイルのワークブック--/'
Dim iWS As Worksheet '/--インプットファイルのワークシート--/'
Dim cWS As Integer '/--シート数格納--/'
Dim s As Integer '/--シート数カウンタ--/'
Dim n As Integer '/--年周回カウンタ--/'
Dim y As Long '/--インプットファイル 行カウンタ--/'
Dim yI As Long '/--インプットファイル 行数格納--/'
Dim yO As Long '/--アウトプットファイル 行数格納--/'
Dim yR As Long '/--処理結果 行数格納--/'
Dim strNo1 As String '/--番号1Block目--/'
Dim strNo2 As String '/--番号2Block目--/'
Dim strNo3 As String '/--番号3Block目--/'
Dim strNo4 As String '/--番号4Block目--/'
Dim strName As String '/--氏名--/'
Dim lngFromY As String '/--対象期間（前）（年）--/'
Dim intFromM As String '/--対象期間（前）（月）--/'
Dim dateFrom As Date '/--対象期間（前）（年月）--/'
Dim lngToY As String '/--対象期間（後）（年）--/'
Dim intToM As String '/--対象期間（後）（月）--/'
Dim dateTo As Date '/--対象期間（後）（年月）--/'
Dim lngDiffY As Long '/--対象期間（年）--/'
Dim lngDiffM As Long '/--対象期間（月）--/'
Set mWB = ActiveWorkbook
strFP = mWB.Sheets("メイン").Cells(2, 2).Value
'/--データが残ってたりしないよう、先にデータを消去--/'
mWB.Sheets("処理結果").Select
mWB.Sheets("処理結果").Range(Rows(3), Rows(Rows.Count)).Clear
mWB.Sheets("output").Select
mWB.Sheets("output").Range(Rows(2), Rows(Rows.Count)).Clear
yR = 3
yO = 2
strFN = Dir(strFP & "\*.xls*")
Do Until strFN = ""
Select Case strFN
'/--見つけたファイルがマクロファイルの場合は何もしない--/'
Case mWB.Name
'/--見つけたファイルがマクロファイル以外の場合--/'
Case Else
Set iWB = Workbooks.Open(strFP & "\ " & strFN)
cWS = iWB.Worksheets.Count
For s = 2 To cWS
Set iWS = iWB.Sheets(s)
strNo1 = ""
strNo2 = ""
strNo3 = ""
strNo4 = ""
strName = ""
lngFromY = 0
intFromM = 0
lngToY = 0
intToM = 0
yI = iWS.Cells(Rows.Count, 1).End(xlUp).Row
For y = 2 To yI
'/--インプット情報を取得--/'
strNo1 = iWS.Cells(y, 1)
strNo2 = iWS.Cells(y, 2)
strNo3 = iWS.Cells(y, 3)
strNo4 = iWS.Cells(y, 4)
strName = iWS.Cells(y, 5)
lngFromY = CLng(iWS.Cells(y, 6))
intFromM = CInt(iWS.Cells(y, 7))
lngToY = CLng(iWS.Cells(y, 8))
intToM = CInt(iWS.Cells(y, 9))
'/--データの期間を計算--/'
dateFrom = DateSerial(lngFromY, intFromM, 1)
dateTo = DateSerial(lngToY, intToM, 1)
lngDiffM = DateDiff("m", dateFrom, dateTo)
'/--検証用シートに共通項目だけ転記--/'
With mWB.Sheets("処理結果")
.Cells(yR, 1).Value = iWB.Name
.Cells(yR, 2).Value = iWS.Name
.Cells(yR, 3).Value = y
.Cells(yR, 4).Value = strNo1
.Cells(yR, 5).Value = strNo2
.Cells(yR, 6).Value = strNo3
.Cells(yR, 7).Value = strNo4
.Cells(yR, 8).Value = strName
.Cells(yR, 9).Value = lngFromY
.Cells(yR, 10).Value = intFromM
.Cells(yR, 11).Value = lngToY
.Cells(yR, 12).Value = intToM
End With
'/--データ期間ごとの処理--/'
Select Case lngDiffM
Case Is < 12 '/--同月含む12か月以内の場合--/'
'/--検証用シートに１レコード分だけ転記--/'
With mWB.Sheets("処理結果")
.Cells(yR, 13).Value = lngFromY
.Cells(yR, 14).Value = intFromM
.Cells(yR, 15).Value = lngToY
.Cells(yR, 16).Value = intToM
End With
'/--アウトプット用シートに１レコード分だけ転記--/'
With mWB.Sheets("Output")
.Cells(yO, 1).Value = strNo1
.Cells(yO, 2).Value = strNo2
.Cells(yO, 3).Value = strNo3
.Cells(yO, 4).Value = strNo4
.Cells(yO, 5).Value = strName
.Cells(yO, 6).Value = lngFromY
.Cells(yO, 7).Value = intFromM
.Cells(yO, 8).Value = lngToY
.Cells(yO, 9).Value = intToM
End With
yR = yR + 1
yO = yO + 1
Case Else '/--同月含む13か月以上の場合--/'
'/--何年跨いでいるかの期間を取得--/'
lngDiffY = DateDiff("yyyy", dateFrom, dateTo)
'/--年跨ぎ分の周回処理--/'
For n = 0 To lngDiffY
'/--検証用シートに対象期間（年）+n年の情報を転記--/'
With mWB.Sheets("処理結果")
.Cells(yR, n * 4 + 13).Value = lngFromY + n
If n = 0 Then
.Cells(yR, n * 4 + 14).Value = intFromM
Else
.Cells(yR, n * 4 + 14).Value = 1
End If
.Cells(yR, n * 4 + 15).Value = lngFromY + n
If n = lngDiffY Then
.Cells(yR, n * 4 + 16).Value = intToM
Else
.Cells(yR, n * 4 + 16).Value = 12
End If
End With
'/--アウトプット用シートに対象期間（年）+n年の情報を転記--/'
With mWB.Sheets("Output")
.Cells(yO, 1).Value = strNo1
.Cells(yO, 2).Value = strNo2
.Cells(yO, 3).Value = strNo3
.Cells(yO, 4).Value = strNo4
.Cells(yO, 5).Value = strName
.Cells(yO, 6).Value = lngFromY + n
If n = 0 Then
.Cells(yO, 7).Value = intFromM
Else
.Cells(yO, 7).Value = 1
End If
.Cells(yO, 8).Value = lngFromY + n
If n = lngDiffY Then
.Cells(yO, 9).Value = intToM
Else
.Cells(yO, 9).Value = 12
End If
yO = yO + 1
End With
Next n
yR = yR + 1
End Select
Next y
Set iWS = Nothing
Next s
End Select
iWB.Close
Set iWB = Nothing
strFN = Dir()
Loop
'/--アウトプット用シートを新規ブックにコピーして保存--/'
Application.DisplayAlerts = False
Sheets("Output").Select
Sheets("Output").Copy
ActiveWorkbook.SaveAs Filename:=strFP & "\output.xls", FileFormat:=xlExcel8
ActiveWindow.Close
Application.DisplayAlerts = True
Set mWB = Nothing
End Sub
３．マクロ処理結果
処理結果のシートには検証のデータが、
Outputのシートには実際にファイル出力されるデータが転記され
インプットファイルと同じフォルダにoutput.xlsというファイルが出力されます。
■マクロ解説
１．データの期間を計算
'/--データの期間を計算--/'
dateFrom = DateSerial(lngFromY, intFromM, 1)
dateTo = DateSerial(lngToY, intToM, 1)
lngDiffM = DateDiff("m", dateFrom, dateTo)
・dateFrom = DateSerial(lngFromY, intFromM, 1)
年（lngFromY）、月（intFromM）、日（1）で日付のシリアル値（1900/1/1からの経過日数）を日付型のdateFromへ格納しています。
lngFromY：対象期間（前）（年）
intFromM：対象期間（前）（月）
同じようにdateTo = DateSerial(lngToY, intToM, 1)で対象期間（後）の年月日も日付型で格納しています。
・lngDiffM = DateDiff("m", dateFrom, dateTo)
dateFromからdateToまでの期間を月単位で計算し、数値型lngDiffMへ格納しています。
２．13か月以上の処理
lngDiffMが12以上（同月はlngDiffM=0となるので、13か月目は12となります。）は13か月以上として処理します。
'/--何年跨いでいるかの期間を取得--/'
lngDiffY = DateDiff("yyyy", dateFrom, dateTo)
'/--年跨ぎ分の周回処理--/'
For n = 0 To lngDiffY
'/--アウトプット用シートにfrom対象期間+n年の情報を転記--/'
With mWB.Sheets("Output")
.Cells(yO, 1).Value = strNo1
.Cells(yO, 2).Value = strNo2
.Cells(yO, 3).Value = strNo3
.Cells(yO, 4).Value = strNo4
.Cells(yO, 5).Value = strName
.Cells(yO, 6).Value = lngFromY + n
If n = 0 Then
.Cells(yO, 7).Value = intFromM
Else
.Cells(yO, 7).Value = 1
End If
.Cells(yO, 8).Value = lngFromY + n
If n = lngDiffY Then
.Cells(yO, 9).Value = intToM
Else
.Cells(yO, 9).Value = 12
End If
yO = yO + 1
End With
Next n
・lngDiffY = DateDiff("yyyy", dateFrom, dateTo)
dateFromからdateToまでの期間を年単位で計算し、数値型lngDiffMへ格納しています。
これにより何年跨いだかが判明します。
・For n = 0 To lngDiffY
跨いだ年数分周回させます。
・.Cells(yO, 6).Value = lngFromY + n
１年目はn=0なので「lngFromY：対象期間（前）（年）」の値が入り、
２年目はn=1となり「lngFromY」の１年後の年が入ります。
このようにnが+1されるごとに1年後の値が入るようになります。
・If n = 0 Then
.Cells(yO, 7).Value = intFromM
Else
.Cells(yO, 7).Value = 1
End If
１年目(n=0)は「intFromM：対象期間（前）（月）」の値が入りますが、2年目以降は対象期間（前）（月）は1月であるべきなので、n>0は1が入るようにしています。
・If n = lngDiffY Then
.Cells(yO, 9).Value = intToM
Else
.Cells(yO, 9).Value = 12
End If
最終年目(n=lngDiffY)は「intFromM：対象期間（後）（月）」の値が入りますが、最終年-1年目までは対象期間（後）（月）は12月であるべきなので、n<lngDiffYは12が入るようにしています。
・yO = yO + 1
意外と忘れがちですが、13か月以上の場合は年毎に分割（インプット1に対してアウトプット複数）なので、この周回の中で「yO：Outputシートの行」を+1していきます。
このようにDateSerial、DateDiffを組み合わせ期間を取得、その期間の中で年と月をどのよう表現すればよいか考えると条件にある
２．インプットファイル、“対象期間（前）”と“対象期間（後）”の月数が、12か月以内のものは、そのまま転記し、13か月以上のものは"1月～12月”の表示形式で最大12か月の期間で行を分ける。（1行の内、期間は年を跨がない）
を達成できるようになります。
↓よろしければクリックをお願いします！
TOPページへ戻る
■社内DX案件紹介
【社内DX案件紹介】アンケートの集計-１-
【社内DX案件紹介】アンケートの集計-２-
【社内DX案件紹介】架電内容ごとの情報振り分け-1-
【社内DX案件紹介】架電内容ごとの情報振り分け-2-
【社内DX案件紹介】2つのファイルの内容を比較する
【社内DX案件紹介】封入物の重さによって印刷会社を変える
【社内DX案件紹介】値の入っているシートのみ印刷する
■社内DXの進め方
【社内DXの進め方】ブログの目的（会社が求めるDX）
【社内DXの進め方】社内DXの推進について
【社内DXの進め方】社内DXは具体的に何をすればよいのか？
【社内DXの進め方】なぜ今Excelか？
