VBAを利用して、ファイル名に共通性がある２ファイルをコピーし１ファイルに集約したい

maru_soraと申します。VBA初心者です。
以下の作業をVBAで行いたく、ネットでいろいろと調べているのですがなかなかうまくいきません。
ゼロベースからの質問で心苦しいのですが、ご教授いただけますとと大変うれしいです。

【ファイル構成】
Aフォルダ、Bフォルダそれぞれ内に営業担当別エクセルファイル（各フォルダ100以上）が以下のようなネーミングであります。

＜Aフォルダ＞　共通2シート構成（2018シート、2019シート）
A001_山田_2019xlsx
A002_佐藤_2019xlsx
A003_渡邉_2019xlsx
　　　　・
　　　　・

＜Bフォルダ＞　共通１シート構成（2020シート）
A001_山田_2020xlsx
A002_佐藤_2020xlsx
A003_渡邉_2020xlsx
　　　　・
　　　　・

【やりたいこと】
●Bフォルダ下の営業担当別エクセルファイルの＜2020シート＞を、Aフォルダ下のファイル名の頭4桁が同じエクセルの＜2019シート＞右にコピーしたい。
●これをBフォルダ下の全てのファイルに対して行いたい。（BフォルダにあってAフォルダにない営業担当別エクセルファイルに対しては処理はしない）

例）Bフォルダ下のA01_山田_2020xlsxにある＜2020シート＞を、Aフォルダ下のA01_山田_2019xlsxの＜2019シート＞右にコピー

うまく説明できていないかもしれませんが、どうぞよろしくお願いいたします。

No.5 ベストアンサー 回答者： GooUserラック 回答日時： 2020/02/11 06:04

No.4 について補足

もちろん以下は環境に合わせて下さい。(こちらのテスト環境をそのまま上げてしまいました)

Const Aフォルダ As String = "D:\共有\test\VBAを利用して、ファイル名に共通性がある２ファイルをコピーし１ファイルに集約したい\Aフォルダ\"
Const Bフォルダ As String = "D:\共有\test\VBAを利用して、ファイル名に共通性がある２ファイルをコピーし１ファイルに集約したい\Bフォルダ\"

この回答へのお礼

GooUserラック様、いただいた情報で作業ができました!！あの大変な作業が一発でと感動してます。
なんとなく理解はできるかも。。　というさみしい状況ではありますがが、きちんと理解できるよう頑張ります！
本当にありがとうございました！！！

お礼日時：2020/02/12 12:33

No.4 回答者： GooUserラック 回答日時： 2020/02/11 06:01

No.3 の修正です。

大変申し訳ございません。差替えて下さい。

Sub Sample()

Const Aフォルダ As String = "D:\共有\test\VBAを利用して、ファイル名に共通性がある２ファイルをコピーし１ファイルに集約したい\Aフォルダ\"
Const Bフォルダ As String = "D:\共有\test\VBAを利用して、ファイル名に共通性がある２ファイルをコピーし１ファイルに集約したい\Bフォルダ\"
Dim 作業 As String
Dim Aファイル辞書 As Object
Dim ファイル名 As String
　
　Set Aファイル辞書 = CreateObject("Scripting.Dictionary")
　作業 = Dir(Aフォルダ & "*.xlsx")
　Do While 作業 <> ""
　　ファイル名 = Mid(作業, 1, Len(作業) - 9) & "2020.xlsx"
　　Aファイル辞書.Add ファイル名, 作業
　　作業 = Dir()
　Loop
　作業 = Dir(Bフォルダ & "*.xlsx")
　Do While 作業 <> ""
　　If Aファイル辞書.Exists(作業) Then
　　　Workbooks.Open Filename:=Aフォルダ & Aファイル辞書.Item(作業)
　　　Workbooks.Open Filename:=Bフォルダ & 作業
　　　Application.DisplayAlerts = False
　　　Sheets("2020シート").Copy After:=Workbooks(Aファイル辞書.Item(作業)).Sheets("2019シート")
　　　ActiveWorkbook.Save
　　　ActiveWindow.Close
　　　ActiveWindow.Close
　　　Application.DisplayAlerts = True
　　End If
　　作業 = Dir()
　Loop
　Set Aファイル辞書 = Nothing

End Sub

No.3 回答者： GooUserラック 回答日時： 2020/02/11 05:36

このような物はいかがですか?

※ Aフォルダのブックに「2019シート」が無いとエラーします
※ Bフォルダのブックに「2020シート」が無いとエラーします
※ いずれも対応可能ですが必要ですか？必要な場合はどのように処理をすれば良いですか？

Sub Sample()

Const Aフォルダ As String = "D:\test\Aフォルダ\" '環境に合わせて下さい
Const Bフォルダ As String = "D:\test\Bフォルダ\" '環境に合わせて下さい
Dim 作業 As String
Dim Aファイル辞書 As Object
Dim ファイル名 As String
　
　Set Aファイル辞書 = CreateObject("Scripting.Dictionary")
　作業 = Dir(Aフォルダ & "*.xlsx")
　Do While 作業 <> ""
　　ファイル名 = Mid(作業, 1, Len(作業) - 9) & "2020.xlsx"
　　Aファイル辞書.Add ファイル名, 作業
　　作業 = Dir()
　Loop
　作業 = Dir(Bフォルダ & "*.xlsx")
　Do While 作業 <> ""
　　If Aファイル辞書.Exists(作業) Then
　　　Workbooks.Open Filename:=Aフォルダ & Aファイル辞書.Item(作業)
　　　Workbooks.Open Filename:=Bフォルダ & 作業
　　　Application.DisplayAlerts = False
　　　Sheets("2020シート").Copy After:=Workbooks(Aファイル辞書.Item(作業)).Sheets("2019シート")
　　　ActiveWindow.Close
　　　ActiveWorkbook.Save
　　　ActiveWindow.Close
　　　Application.DisplayAlerts = True
　　End If
　　作業 = Dir()
　Loop
　Set Aファイル辞書 = Nothing

End Sub

この回答へのお礼

Qchan1962さん
細かくご説明いただきありがとうございました！
初心者すぎで難易度すらわからなかった事実に少し悲しくなりつつ、奥深さを痛感してます。
時間はかかるとは思いますが、いただいたご説明を理解できるよう頑張ります！

お礼日時：2020/02/12 12:32

No.2 回答者： Qchan1962 回答日時： 2020/02/11 03:40

VBAはデモ環境を作って試してください。

説明を含め長文なので、不明な点は聞いてください。
但し、追加依頼みたいなのは、嫌ですよ。

一応、ローカルで環境を作って検証してありますので大丈夫かと思いますが

Sub CopySheets_EX()
Dim i As Long
Dim Folder_PathA As String, Folder_PathB As String
Dim Array_fileB() As Variant, Array_fileA() As Variant
Dim myTitle As String, TgtSheet As String
Dim MyBook As Workbook

　　myTitle = "Bフォルダ（コピー元フォルダ）を選択してください。"
　　Call FileGet(myTitle, Array_fileB(), Folder_PathB)
　　myTitle = "Aフォルダ（コピー先フォルダ）を選択してください。"
　　Call FileGet(myTitle, Array_fileA(), Folder_PathA)

　　TgtSheet = "2020シート"
　　Application.DisplayAlerts = False
　　Application.ScreenUpdating = False
　　For i = 0 To UBound(Array_fileB)
　　　　Set MyBook = Workbooks.Open(Folder_PathB & Array_fileB(i))
　　　　Call TargetBooks_CopySheets_insertion(MyBook.Name, Folder_PathA, TgtSheet, Array_fileA)
　　　　MyBook.Save
　　　　MyBook.Close
　　　　Set MyBook = Nothing
　　Next
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True

　　MsgBox ("終了しました")
End Sub

'//////////-----複数ブックに複数のコピーシートを挿入する
Sub TargetBooks_CopySheets_insertion(MyBook_Name As String, ByVal Folder_Path As String, ByVal Copy_SheetName As Variant, ByVal Target_book As Variant)
Dim Book_Name As Variant
　　For Each Book_Name In Target_book
　　　　If Left(MyBook_Name, 4) = Left(Book_Name, 4) Then
　　　　　　With Workbooks.Open(Folder_Path & Book_Name)
　　　　　　　　If (.ProtectStructure Or .ProtectWindows) Then　　'保護されたブックをSkip
　　　　　　　　　　.Close
　　　　　　　　　　GoTo NGbooks
　　　　　　　　End If
　　　　　　　　Workbooks(MyBook_Name).Activate
　　　　　　　　Workbooks(MyBook_Name).Worksheets(Copy_SheetName).Copy , .Worksheets(.Worksheets.Count)
　　　　　　　　.Worksheets(.Worksheets.Count).Activate
　　　　　　　　.Save
　　　　　　　　.Close
　　　　　　End With
　　　　　　Exit For
　　　　End If
NGbooks:
　　Next
End Sub

Function FileGet(myTitle As String, Array_file() As Variant, Folder_Path As String) As Variant()
Dim i As Long
Dim first_path As String
Dim File_Name As String
Dim Extension As String
　　'//////////-----拡張子設定
　　Extension = ".xlsx"
　　'//////////-----ダイアログでフォルダの指定
　　first_path = CreateObject("WScript.Shell").SpecialFolders("desktop")　　'ダイアログの初期 Pathをデスクトップにしています。
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　.Title = myTitle
　　　　.InitialFileName = first_path
　　　　If .Show = True Then
　　　　　　Folder_Path = .SelectedItems(1) & "\"
　　　　End If
　　End With
　　If Folder_Path = "" Then End
　　'//////////-----フォルダ内のファイル名取得し配列へ
　　File_Name = Dir(Folder_Path & "*" & Extension)
　　Do While File_Name <> ""
　　　　ReDim Preserve Array_file(i)
　　　　Array_file(i) = File_Name
　　　　i = i + 1
　　　　File_Name = Dir()
　　Loop
　　FileGet = Array(myTitle, Array_file(), Folder_Path)
End Function

No.1 回答者： Qchan1962 回答日時： 2020/02/11 03:36

こんばんは、

内容を見ると、さすがにVBA初心者では、理解して組み立てるには、かなりの時間がかかるかと思います。
説明自体、うん、、と言う感じ。どうすればいいかなと、考えましたが、、取り敢えず
質問の解釈に間違いなければ、おそらく希望通りになるだろうVBAを書きます。
VBAの導入方法は、知っていると思いますので、新規ブックを作りVBEで標準モジュールを挿入して一旦、任意の場所に
マクロ有効ブックとして保存してください。Book名は何でも良いです。
基本的にこのブックは、マクロを実行するブックですので、シート内も空白で良いです。
下記コード全てを標準モジュールにコピペしてください。

実行プロシージャはCopySheets_EXになります。ボタンに登録したり、Alt+F8などから実行します。
実行すると初めに　例にあるようにBフォルダがコピー元フォルダを選ぶダイアログが表示されますので選んでOK
次に同じくAフォルダがコピー先フォルダを選ぶダイアログが表示されますので選んでOK
あとは、処理を待つだけです。

頭の文字4文字が重複して同じフォルダにある場合、正しく処理できません。一意になるまで桁数を増やすことは出来ます。
1000位のファイル数なら心配ないと思いますが、少々時間はかかるかと、、

少しのファイルで試してください。
直ぐには、分からないと思いますが、処理の流れ、、

初めにコピー元のファイル情報を配列に入れます。
Function FileGet(myTitle As String, Array_file() As Variant, Folder_Path As String) As Variant()　内がそれです。
ダイアログを出し、ユーザーにファルダを選択させ中のファイル名を配列に入れ、合わせてパスを戻します。
今回、同じ処理をコピー先でも行うので、Functionにしています。

次にコピーするシート名を変数に代入します。
TgtSheet = "2020シート"
ここを工夫（配列などに）すれば、複数シートを挿入する事も出来ます。

Bファルダのファイルを配列を基に開きます。
　　For i = 0 To UBound(Array_fileB)
　　　　Set MyBook = Workbooks.Open(Folder_PathB & Array_fileB(i))
各情報をメイン処理に渡します。
Call TargetBooks_CopySheets_insertion(MyBook.Name, Folder_PathA, TgtSheet, Array_fileA)
MyBook.Nameは、コピー元ブック名
Folder_PathAは、挿入先パス
TgtSheetは、シート名
Array_fileAは、Aフォルダ内のファイル名配列
＊受け取り側と変数名が違うが、ご愛敬（大丈夫）
受け取り側
Sub TargetBooks_CopySheets_insertion(MyBook_Name As String, ByVal Folder_Path As String, ByVal Copy_SheetName As Variant, ByVal Target_book As Variant)
Aフォルダのファイルを順次あたり、条件（頭の文字4文字が同じなら）開く
　　For Each Book_Name In Target_book
　　　　If Left(MyBook_Name, 4) = Left(Book_Name, 4) Then　
　　　　　　With Workbooks.Open(Folder_Path & Book_Name)
保護されたブックは無いと思いますが、一応。
If (.ProtectStructure Or .ProtectWindows) Then　　'保護されたブックをSkip
　　　　　　　　　　.Close
　　　　　　　　　　GoTo NGbooks

メイン
Bフォルダの開いているブックのシート（2020シート）をCopyして右に挿入　　！これ2019シートのすぐ右になるかな？シート名検索プロセス入れるの忘れた取り敢えずこれで。
　　　　　　　　Workbooks(MyBook_Name).Activate
　　　　　　　　Workbooks(MyBook_Name).Worksheets(Copy_SheetName).Copy , .Worksheets(.Worksheets.Count)
　　　　　　　　.Worksheets(.Worksheets.Count).Activate
　　　　　　　　.Save
　　　　　　　　.Close
保存して閉じる。。
ファイルがなくなる（配列が）まで繰り返します。

説明書いてたら、文字数オーバーになってしまいました。
コードは、次に書きます。
分からないと思いますが、、1つ1つ確認してくださいね。