サブフォルダからエクセルブックをとりだすマクロ

質問

特定のフォルダからエクセルブックのみを抽出し別のフォルダに集める（コピーする）マクロを作りたいと思い、以下のように作成しました。
（AAAフォルダ⇒移動元、BBBフォルダ⇒移動先）
ただしこれだと、AAAフォルダ内にあるサブフォルダからは拾ってこれないようです。
AAA内の全てのサブフォルダからエクセルブックを拾ってくるにはどう修正すればよろしいでしょうか。

―――――――――――

Sub sample1()

Dim FSO As Object, fld As Variant, bk As Variant
Const Fld1 As String = "C:\AAA"
Const Fld2 As String = "C:\BBB\"
Const tgt As String = "*.xlsx"

Set FSO = CreateObject("Scripting.FileSystemObject")
For Each fld In FSO.GetFolder(Fld1).SubFolders
For Each bk In fld.Files
If bk.Name Like tgt Then
bk.Copy Fld2
End If
Next bk
Next fld

End Sub

回答No.5

real beatin（@realbeatin）

こんにちは。No.2補足欄への返信です。

> 「AAAフォルダ > 配下のサブフォルダ > 配下のサブフォルダ まで含め」てエクセルブックを集めるにはどうしたらよいかという意図の質問でした。
それはそれでいいのですが、
何がうまく行っていて、何がうまく行っていないのか、
という点は、まだ、こちらに向けて説明されていませんよね。
一般論として、扱う階層を深くすればするほど、
「フォルダ名以外は全く同じ名前のファイル」を扱う可能性が増えますから、
例えば「同じ名前のブックが無いことは担保される」とか、そうじゃないとか、
そういった条件次第で、こちらが書く内容は変わってくる、ということは、
No.2で既に説明したつもりです。
この点にレスがない、ということは、
　専ら階層を深める事さえ出来ればよし
　同名ファイルの上書きについては無視してよい、
という理解でいます。

ということで、こちらもNo.2補足を前提に一旦リセットした形でお応えします。

□モジュールの宣言部を使うことになりますので、
試す時には、紛れが無いよう、新しく標準モジュールを作成してから
モジュールの先頭にスクリプトを貼り付けるなど注意してみて下さい。
□実行するプロシージャは、Sub ReW9113611　です。
□上述の通り、今回は、
「ひとつのフォルダに同名のファイルをコピーすると上書きされてしまう」
ことへの対策はしていません。
　Scripting.File.Copy メソッドの引数には、
元質問でご提示のようにフォルダパスだけを指定する方法と、
No.2で提示したように、フルパス（フルネーム）を指定する方法と、
が、ありますので、必要に応じてそちらで応用、使い分けてください。
★Scriptingへの参照設定『Microsoft Scripting Runtime』
を行ってから開発にあたる方が、何かと易しいでしょうから、
参照設定した場合のスクリプト（宣言）を★コメントとして併記しておきます。
開発時には参照設定、配布時には参照設定に依存しない書き方、
という風に分けた方が、開発の速度が高まると思います。
●指定（変更）が必要なパラメータについては●マークにて、、、。
再帰処理を扱う場合は、通常、深度の上限を設けることが多いです。
というより、最大の階層数を決め打ちにしたものの方が、
扱い易いですし、他者にも受け容れられ易いでしょう。
N_SUBDIR_DEPTH_LMT ... 仮に、２つ下の階層まで、としていますが、
大き過ぎない数字で、十分な数字を指定するようにしてください。
また、もしも、ここに概ね 3 よりも大きい数字を指定するような場合は、
フォルダデザインまたはマクロの設計を見直した方が好いように思います。
やや無理し過ぎ、というか、誰が書いてもトラブル回避が難しくなります。
簡易的に安全策を取るなら、ループ内の何処かに
　　DoEvents
など、書き加えておいて、
ユーザー操作による処理中断に備えておけば、多少は安心です。
▼フォルダの階層構造を視覚的に確認できるように、
イミディエイトウィンドウへの出力処理を▼コメントとして併記しています。
確認したい時だけ、コメントを外して実行してみてください。

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
' ' 以下　〓〓　モジュール宣言部（先頭）〓〓
Option Explicit

Private oFSO As Object
'Private oFSO As Scripting.FileSystemObject　'　★参照設定（Scripting　Microsoft Scripting Runtime）
Private Const S_DIR_SRC As String = "C:\AAA"　'　●要指定　コピー元フォルダパス
Private Const S_DIR_DEST As String = "C:\BBB\"　'　●要指定　コピー先フォルダパス
Private Const S_EXTE As String = "*.xlsx"　'　●要指定　*拡張子
Private Const N_SUBDIR_DEPTH_LMT As Long = 2　'　●要指定　サブフォルダの階層深度　上限を指定
' ' 以上　〓〓　モジュール宣言部（先頭）〓〓

' ' ///　メイン（実行）プロシージャ
Sub ReW9113611()
　　Set oFSO = CreateObject("Scripting.FileSystemObject")
'　　Set oFSO = New Scripting.FileSystemObject　'　★

　　Call SubW9113611(oFSO.GetFolder(S_DIR_SRC))
End Sub

' ' ///　サブプロシージャ　（再帰呼び出しアリ）
Sub SubW9113611(oDir As Object, Optional ByVal nDep As Long)
Dim oSubDir As Object, oFile As Object
'Sub SubW9113611(oDir As Scripting.Folder, Optional ByVal nDep As Long)　'　★
'Dim oSubDir As Scripting.Folder, oFile As Scripting.File　'　★

　　'Debug.Print String(nDep, vbTab) & ">\"; oDir.Name,　'　▼イミディエイトウィンドウで階層確認
　　'Debug.Print "f:"; oDir.Files.Count, "sd:"; oDir.SubFolders.Count　'　▼

' ' ファイルをコピー
　　For Each oFile In oDir.Files
　　　　If oFile.Name Like S_EXTE Then
　　'Debug.Print String(nDep + 1, vbTab) & oFile.Name　'　▼
　　　　　　oFile.Copy S_DIR_DEST
　　　　End If
　　Next oFile

' ' サブフォルダの階層深度　上限　を超える場合は処理を抜ける
　　If nDep >= N_SUBDIR_DEPTH_LMT Then Exit Sub

' ' サブフォルダ毎に再帰呼出
　　For Each oSubDir In oDir.SubFolders
　　　　Call SubW9113611(oSubDir, nDep + 1)
　　Next oSubDir
End Sub
' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

回答No.4

ushi2015

こんばんは
No1です。
すみません、標準モジュールの
先頭、Sub sample2_1()の前に
Dim FSO as Object
を入れておいて下さい。
コピーし忘れてました。

回答No.3

ushi2015

こんにちは
No1です。
Fld1とFld2の指定は変更しておいて下さい。

回答No.2

real beatin（@realbeatin）

こんにちは。

> ただしこれだと、AAAフォルダ内にあるサブフォルダからは拾ってこれないようです。
「うまく行かない」といった状況の説明は、
もう少し具体的、限定的にした方が好いです。
AAAフォルダ配下のすべてのサブフォルダからすべてのExcelブック（.*xlsx）を
BBBフォルダへコピーする、、、ということまでは理解出来ますが、結果として、
例えば、
「ひとつもコピーされない」
とか
「ひとつのサブフォルダにある分だけがコピーされる」
とか、、、。

とりあえず、後者の状況なのだとして、
よく見かけるフォルダデザインとして、
日付や部署名などといった属性をサブフォルダ名だけで表現しているような例、
　　（サブ）ファルダ内のブック名はサブフォルダを跨いで共通になっていて、
　　（サブ）フォルダの名前でしか、ファイル（ブック）パスに相違がない
というような場合を想定してみました。
> bk.Copy Fld2
上の条件で、この記述を実行した場合は、
BBBフォルダへコピーはすべてのブックに対して実行されるものの、
BBBフォルダ内での名前が同一のものはすべて上書きになってしまうので、
結果的に「ひとつのサブフォルダにある分だけがコピーされる」ことになります。
　bk.Copy Fld2 & fld.Name & "_" & bk.Name
のように、
「コピー元サブフォルダの名前をブック名に付け加える」
といった対策で、この状況であれば、
> AAA内の全てのサブフォルダからエクセルブックを拾ってくるにはどう修正すればよろしいでしょうか。
への答にはなっているかと。

「ひとつもコピーされない」
状況については、ＯＳ側で設定される書き込み権限の問題を
一度は確認した方が宜しいかと。
この場合は特に、各バージョン情報が無いと、アドバイスは難しいです。

尚、
AAAフォルダ > 配下のサブフォルダ > 配下のサブフォルダ まで含めたい、
というお話には読めませんでしたので、今回は、
その点についてお応えしませんが、
もし、そういうことでしたら、再帰処理するのが一般的です。

差し当たり以上です。
何か不足があれば補足してください。

補足

丁寧なご回答をいただいたところ大変申し訳ありませんが、質問文に間違いがありました。
「AAAフォルダ > 配下のサブフォルダ > 配下のサブフォルダ まで含め」てエクセルブックを集めるにはどうしたらよいかという意図の質問でした。
失礼いたしました。

再帰処理というものがあるんですね。
頑張って理解に努めたいと思います。

回答No.1

ushi2015

こんにちは
今のコードでも"C:\AAA"の1階層分のサブフォルダー内のファイルはコピー出来てる
と思いますが、"C:\AAA"内のファイルと、全ての階層のサブフォルダー内のファイル
をコピーするなら、

Sub sample2_1()
　　Const Fld1 As String = "C:\temp"
　　Const Fld2 As String = "C:\data\"
　　Const tgt As String = "*.xlsx"
　　Dim bk As Variant

　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　For Each bk In FSO.GetFolder(Fld1).Files
　　　　If bk.Name Like tgt Then
　　　　　　bk.Copy Fld2
　　　　End If
　　Next bk
　　Call sample2_2(Fld1, Fld2, tgt)
　　Set FSO = Nothing
End Sub
Sub sample2_2(ByVal Fld1 As String, ByVal Fld2 As String, ByVal tgt As String)
　　Dim fld As Object
　　Dim bk As Variant
　　For Each fld In FSO.GetFolder(Fld1).SubFolders
　　　　For Each bk In fld.Files
　　　　　　If bk.Name Like tgt Then
　　　　　　　　bk.Copy Fld2
　　　　　　End If
　　　　Next bk
　　　　Call sample2_2(ByVal fld.Path, ByVal Fld2, ByVal tgt)
　　Next fld
　　Set fld = Nothing
End Sub
こんな、感じです。
エラー処理は適宜入れて下さい。

補足

すみません。質問文に間違いがありました。
おっしゃる通り、
"C:\AAA"の1階層分のサブフォルダーだけでなく、「全ての」階層のサブフォルダーからエクセルブックを集めるにはどうすればよいか、という質問でした。
こちらの意図をくんでくださり、ありがとうございます。

また質問ばかりで恐縮なのですが、sample2_2の
For Each fld In FSO.GetFolder(Fld1).SubFolders
の部分で実行時エラー424「オブジェクトが必要です」が出てしまうようなのですが、どのように対処すればよろしいでしょうか。