VBAでカレントフォルダ配下のフォルダに存在する指定したファイルを任意のフォルダにコピーする

VBAでカレントフォルダ配下のフォルダに存在する指定したファイルを任意のフォルダにコピーするマクロを作成したいのですが、フォルダ(フルパス)とファイル名を指定してコピーするマクロしか作成できませんでした。ご教授いただきたいです。

【前提】
「SAMPLE.xlsm」が存在するフォルダをカレントフォルダにする。

【状況】
「C:\SAMPLE」にSAMPLE.xlsmが存在している。
下記のフォルダ構成図のような構成でファイルが格納されている。

【処理】
A列にコピーしたいファイルを列挙する。
カレントフォルダ(SAMPLE.xlsmがあるフォルダ)のサブフォルダに存在する、A列に列挙したファイルを任意フォルダにコピーする。(コピー先のフォルダはC1セルの値でパスを指定する)
A2～A●セルまでFor文でコピーを回す(空白セルになったらループを止める)
サブフォルダに指定したファイル以外のファイルがあっても指定したファイルのみをコピーできるようにする。(「C:\SAMPLE\AAA\AAA_04.c」はコピーしない)

フォルダ構成図
C:\SAMPLE
￤
￤---AAA
￤　　￤---AAA_01.c
￤　　￤---AAA_02.c
￤　　￤---AAA_03.c
￤　　￤---AAA_01.h
￤　　￤---AAA_02.h
￤　　￤---AAA_03.h
￤
￤---BBB
￤　　￤---BBB_01.c
￤　　￤---BBB_02.c
￤　　￤---BBB_03.c
￤　　￤---BBB_01.h
￤　　￤---BBB_02.h
￤　　￤---BBB_03.h
￤
￤---CCC
　　 ￤---CCC_01.c
　　 ￤---CCC_02.c
　　 ￤---CCC_03.c
　　 ￤---CCC_01.h
　　 ￤---CCC_02.h
　　 ￤---CCC_03.h

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2020/07/12 04:27

こんばんは、

＞「SAMPLE.xlsm」が存在するフォルダをカレントフォルダにする。
カレントフォルダとして他の処理に使われるのでしょうか？
ご質問の前提の場合、ThisWorkbook.Path　（VBAが実行されているブックのパス）で
対応可能なので、ThisWorkbook.Pathにします。必要であればfolPath = ThisWorkbook.Pathを変更してください。
また、ThisWorkbook.Pathで不具合が発生する場合、ActiveWorkbook.Pathに変えてみてください。（過去の事例）

＞A列にコピーしたいファイルを列挙する。
流石にコピーしたい情報は分かりません。添付図の様にすでに抽出されているものと考えています。

いくつか不明な点がありますが、こんな感じでどうでしょう。
SAMPLE.xlsmの標準モジュールに

Option Explicit
Sub sample()
Dim FSO As Object, f As Object
Dim AryF As Variant, i As Long
Dim folPath As String, exfol As String, Target As String
　　folPath = ThisWorkbook.Path　'「SAMPLE.xlsm」が存在するフォルダ
　　exfol = Sheets(1).Range("C1").Text　'シート名が不明の為、インデックス1にしてあります。
　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　AryF = Sheets(1).Range("A1:A" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)　'シート名が不明の為、インデックス1にしてあります。A2～A●セルまでの値を配列に入れています。
　　On Error Resume Next　'念のため
　　For i = 1 To UBound(AryF)　'配列要素分ループ
　　　　For Each f In FSO.GetFolder(folPath).SubFolders　'サブフォルダすべてをループ
　　　　　　Target = f & "\" & AryF(i, 1)
　　　　　　If Dir(Target) <> "" Then FSO.GetFile(Target).Copy exfol & "\": Exit For　'あれば指定フォルダ内に保存
　　　　Next f
　　Next i
　　Set FSO = Nothing
　　MsgBox ("完了")
End Sub


A列セルのファイル名には拡張子を含めてください。例：hoge.xlsx　hoge.png など
＞C1セルの値でパスを指定する　パスの最後に\は不要です。コード内で追加しています。例：C:\SAMPLE\hoge\huga

この回答へのお礼

ありがとございました。
助かります。

お礼日時：2020/07/17 22:05