VBA 別々のフォルダに入っている複数ブックの該当シートを移動したい

Excel VBAに関する質問です。
下記の動きをするマクロを組みたいのですが、お知恵をいただけませんでしょうか。

フォルダA、B、Cがある。
３つのフォルダ内には、それぞれ同じ形式だが一部異なる文言を有した
excelブックが複数(70ほど)入っている。

フォルダAにあるブックはすべて1シート構成
フォルダB、Cに入っているブックは、全て4シート構成だが、
必要なのはどちらも2シート目のみ

フォルダAにあるA-1ブックの1シート目の後ろに、
フォルダBのB-1ブック2シート目のみを移動したい。
のち、A-1ブック3シート目に、C-1ブックの2シート目を移動したい。

以降、A-2-2シート目にB-2-2シート目を
A-2-3シート目にC-2-2シート目を移動していきたい

フォルダABC内のブックA-1、B-1、C-1を、全て同じタイトルにすることはOK
（同時に開けなくなるから、同タイトルA、同タイトルB、同タイトルCとかにする？のもOK）

※フォルダA内のブックにあるシートは、全て名前が違う
　フォルダB内のブックにある必要な2シート目は、全て同じ名前
　フォルダC内のブックにある必要な2シート目は、全て同じ名前

伝わりにくく恐縮ですが、ご教示願います。

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2019/09/20 02:22

Option Explicit

Sub ABCSheet_Move_main()
Dim FN_A() As Variant, FN_B() As Variant, FN_C() As Variant
Dim Bk_A, Bk_B, Bk_C, i, mg
　　 FN_A() = Add_Sort()
　　 FN_B() = Add_Sort()
　　 FN_C() = Add_Sort()
　　 On Error Resume Next
　　 If UBound(FN_A) = 0 Or UBound(FN_B) = 0 Or UBound(FN_C) = 0 Then
　　　　　　 MsgBox ("フォルダにファイルがないので実行できません。")
　　　　　　 Exit Sub
　　 End If
　　 '-----ファイル数の確認
　　 If UBound(FN_A) <> UBound(FN_B) Or UBound(FN_B) <> UBound(FN_C) Then
　　　　　　 MsgBox ("ファイルの数が合いませんので実行できません｡ ")
　　　　　　 Exit Sub
　　 End If
　　 '-----まで
　　 With ThisWorkbook.Application
　　　　　　 .ScreenUpdating = False
　　　　　　 .DisplayAlerts = False
　　　　　　 .EnableEvents = False
　　 End With

　　 For i = 1 To UBound(FN_A)
　　　　　　 With Workbooks.Open(FN_A(i))
　　　　　　　　 Bk_A = Application.ActiveWorkbook.name
　　　　　　　　 If Err.Number <> 0 Then
　　　　　　　　　　　　 mg = FN_A(i)
　　　　　　　　　　　　 GoTo NGErr
　　　　　　　　 End If
　　　　　　　　 Worksheets.Add After:=Sheets(Worksheets.Count)
　　　　　　　　 ActiveSheet.name = "B" & i '←シート名
　　　　　　　　 Worksheets.Add After:=Sheets(Worksheets.Count)
　　　　　　　　 ActiveSheet.name = "C" & i '←シート名

　　　　　　　　 With Workbooks.Open(FN_B(i))
　　　　　　　　　　　　 Bk_B = Application.ActiveWorkbook.name
　　　　　　　　　　　　 If Err.Number <> 0 Then
　　　　　　　　　　　　　　 mg = FN_B(i)
　　　　　　　　　　　　　　 GoTo NGErr
　　　　　　　　　　　　 End If
　　　　　　　　　　　　 Workbooks(Bk_B).Worksheets(2).Cells.Copy
　　　　　　　　　　　　 Workbooks(Bk_A).Worksheets(2).Range("A1").PasteSpecial _
　　　　　　　　　　　　　　　　 xlPasteValuesAndNumberFormats
　　　　　　　　　　　　 Application.CutCopyMode = False
　　　　　　　　　　　　 Workbooks(Bk_B).Worksheets(2).Delete '←削除
　　　　　　　　　　　　 .Save
　　　　　　　　　　　　 .Close False
　　　　　　　　 End With
　　　　　　　　 With Workbooks.Open(FN_C(i))
　　　　　　　　　　　　 Bk_C = Application.ActiveWorkbook.name
　　　　　　　　　　　　 If Err.Number <> 0 Then
　　　　　　　　　　　　　　 mg = FN_C(i)
　　　　　　　　　　　　　　 GoTo NGErr
　　　　　　　　　　　　 End If
　　　　　　　　　　　　 Workbooks(Bk_C).Worksheets(2).Cells.Copy
　　　　　　　　　　　　 Workbooks(Bk_A).Worksheets(3).Range("A1").PasteSpecial _
　　　　　　　　　　　　　　　　 xlPasteValuesAndNumberFormats
　　　　　　　　　　　　 Application.CutCopyMode = False
　　　　　　　　　　　　 Workbooks(Bk_C).Worksheets(2).Delete '←削除
　　　　　　　　　　　　 .Save
　　　　　　　　　　　　 .Close False
　　　　　　　　 End With
　　　　　　　　 .Save
　　　　　　　　 .Close False
　　　　　　 End With
　　 Next
　　 MsgBox ("完了しました")
NGErr:
　　 If Err.Number <> 0 Then MsgBox (Err.Number & vbCrLf & mg & " ファイルOpenの処理でエラーが発生しました。")
　　 With ThisWorkbook.Application
　　　　　　 .ScreenUpdating = True
　　　　　　 .DisplayAlerts = True
　　　　　　 .EnableEvents = True
　　 End With

End Sub

Function Add_Sort() As Variant()
Dim i, j, Folder_Path, File_Name, tmp
Dim Array_file()
　　 Erase Array_file
　　 On Error Resume Next
　　 i = 1
　　 With Application.FileDialog(msoFileDialogFolderPicker)
　　　　　　 .InitialFileName = ThisWorkbook.Path
　　　　　　 If .Show = True Then
　　　　　　　　 Folder_Path = .SelectedItems(1) & "\"
　　　　　　 End If
　　 End With
　　 If Folder_Path = "" Then Exit Function
　　 '-----フォルダ内のファイル名取得し配列へ
　　 File_Name = Dir(Folder_Path & "*" & "xls*")
　　 Do While File_Name <> ""
　　　　　　 ReDim Preserve Array_file(i)
　　　　　　 Array_file(i) = Folder_Path & File_Name
　　　　　　 File_Name = Dir()
　　　　　　 i = i + 1
　　 Loop
　　 '--------------ファイル名ソート昇順
　　 For i = 1 To UBound(Array_file)
　　　　　　 tmp = Array_file(i)
　　　　　　 j = i - 1
　　　　　　 Do
　　　　　　　　 If (j < 0) Then
　　　　　　　　　　　　 Exit Do
　　　　　　　　 End If
　　　　　　　　 If (Array_file(j) <= tmp) Then
　　　　　　　　　　　　 Exit Do
　　　　　　　　 End If
　　　　　　　　 Array_file(j + 1) = Array_file(j)
　　　　　　　　 j = j - 1
　　　　　　 Loop
　　　　　　 Array_file(j + 1) = tmp
　　 Next
　　 Add_Sort = Array_file
End Function

この回答へのお礼

わわわ、ありがとうございます…！！！
まさかこんなにご丁寧に回答いただけるとは思わず、驚嘆しております。

考案いただいたコードでテストしてみます！

お礼日時：2019/09/20 14:41

No.1 回答者： Qchan1962 回答日時： 2019/09/20 02:21

はじめまして、返信付きませんね？

この様な質問は、誰かが例になるような回答を付けないと
中々動かないですね。誰か答えるとそれをヒントに回答する方もいるかと思いますので、、
先ずは、ご質問を色々考察したのですが、
＞（同時に開けなくなるから、同タイトルA、同タイトルB、同タイトルCとかにする？のもOK）
などと言うコメントから、VBAの条件に合わせて環境を設定して頂く事にしました。

通常、VBAは、環境、仕様に合わせますが、逆にVBAに合わせた使用方法を提示します。

シート名はインデックス（2）で拾うので良いですが、各ブックの関連性は？、どの様な名前ですか？
となりますが、名前は何でもよいです。

①但し、各フォルダ内のファイル名の関連性は、名前を昇順で並べ替えを行った時に順番に対応するように設定してください。

例えば、ファイル名が番号の場合、Aフォルダの一番若い番号のファイル（挿入されるファイル）は、
Bフォルダの1番若い番号のファイルの2番目のシートとCフォルダの2番目のシートが挿入されます。

シート名は、B1～　C1~　になります。
変更したい場合は、コード内の　←シート名を編集してください。
ただ、変更するプロセスを変える場合は、アクティブなブックを見て行ってくださいね。

＞2シート目を移動していきたい
Bフォルダ、Cフォルダの2番目のシートは削除します。困る場合はコード内の
←削除と示されているコードを削除またはコメントアウトしてください。

＞シート名が同じなのでは、参照ブックシート名にすることは出来ませんので
同じ名前？は、避けたほうが良いと思います。

A,B,Cファイルの数は、同数ですか？となりますが、
一応、フォルダ間違いなどを防ぐ為同数設定しています。
不要な場合、'-----ファイル数の確認の項目を削除してください。
Aフォルダ（挿入されるファイル数ループします）対象がなくなるとエラーが出ます。

②pathが分らないので、UIにします。結果、3回フォルダを聞かれます。
1回目はAフォルダに当たります。
2回目はBフォルダ、3回目はCフォルダです。
選ぶ順番は、重要です。ご注意を。

70×3で210程度のファイルならスタックの心配はないかと思いますが
不明の点があったので、総当たりです。それなりに処理時間がかかると思います。
検証で10ファイル（30ファイル）で2~4秒くらいでしょうか。

Sub ABCSheet_Move_main　がスタートになります。
テストはコピーなどで10ファイルぐらいで実施した方が良いでしょう。
昇順の定義は、フォーマットなどで異なる可能性はありますが、同様の処理を
各ファイルに行うので、関連性があっていれば、気にする必要はありません。

簡単なエラー処理はありますが、単に抜けるだけなので、
誤動作を防ぐレベルではありませんので追加などしてください。
しっかり、処理を理解して自己責任でテストしてください。

やば、７５３文字　オーバーしたので次にコードは示します。