複数のサブフォルダの中身をひとつのフォルダにまとめたい

Question

前提・実現したいこと

「A」→「画像」→「a」
「B」→「画像」→「b」
「C」→「画像」→「c」

という状態で納品されます。
・「」内はフォルダ名、→はサブフォルダを意味します
・真ん中の「画像」は必ずこの名前で納品されます
・「A」「B」「C」は同じフォルダに入っています
・アルファベット部分は毎回名前が変わります（法則性もありません）

「画像」という一つのフォルダに、
「a」「b」「c」のフォルダが格納されている状態を作りたいと思っています。

発生している問題・エラーメッセージ

下記のコードで、
新しく「画像」フォルダを作りその中に「a」を入れる、は出来たのですが、
「b」も「c」も同じフォルダに入れる方法が分からず、困っております。

エラーメッセージ

該当のソースコード

Option Explicit

Sub フォルダをまとめる()

'「画像」フォルダが無ければ新しく作る

Dim objF1 As Object
Set objF1 = CreateObject("Scripting.FileSystemObject")

Dim strFPath1 As String
 
    If objF1.FolderExists(ThisWorkbook.Path & "\" & "画像") Then

    Else
    strFPath1 = objF1.CreateFolder(ThisWorkbook.Path & "\" & "画像")
   
    End If

'「画像」フォルダに移動

Dim FSO As FileSystemObject
Set FSO = New FileSystemObject

Call FSO.MoveFolder(ThisWorkbook.Path & "\フォルダA\画像*", ThisWorkbook.Path & "\画像\")

Set FSO = Nothing

End Sub

試したこと

補足情報（FW/ツールのバージョンなど）

Excel　2013・OSはwindows 7です。
不足情報、不明点等御座いましたらお申し付けください。

Answer 1

あなたが作成したマクロに多少手を加えました。
Const baseFolder As String = "d:\goo\data"
は、移動元のフォルダをまとめたフォルダです。
baseFolder\folderA\画像\subA1
baseFolder\folderA\画像\subA2
baseFolder\folderB\画像\subB1
baseFolder\folderB\画像\subB2

のようにあるとすると、subA1,subA2,SubB1,subB2が移動されます。
ThisWorkbook.Path\画像に移動されます。

ThisWorkbook.Path\画像は、baseFolderの下には作成しないでください。
（作成した場合はThisWorkbook.Path\画像も移動対象となってしまいます）

Sub フォルダをまとめる()

    Const baseFolder As String = "d:\goo\data"  '移動元の「画像」フォルダ
    Dim objF1 As Object
    Set objF1 = CreateObject("Scripting.FileSystemObject")
    Dim strFPath1 As String
    strFPath1 = ThisWorkbook.Path & "\" & "画像"
    '「画像」フォルダが無ければ新しく作る
    If objF1.FolderExists(strFPath1) = True Then
    Else
        Call objF1.CreateFolder(ThisWorkbook.Path & "\" & "画像")
    End If
    Dim FSO As FileSystemObject
    Dim flds As Folders
    Dim fld As Folder
    Dim gflds As Folders
    Dim gfld As Folder
    Dim errmsg As String
    Dim fctr As Long
    Dim ectr As Long
    errmsg = ""
    fctr = 0
    ectr = 0
    Set FSO = New FileSystemObject
    '移動元の「画像」フォルダに移動
    Set flds = FSO.getfolder(baseFolder).subfolders
    For Each fld In flds
        'そのフォルダに「画像」のフォルダがあるなら、その下のフォルダを異動先の画像フォルダへ移動する
        If FSO.FolderExists(fld & "\画像") = True Then
            Set gflds = FSO.getfolder(fld & "\画像").subfolders
            For Each gfld In gflds
                On Error GoTo ERROR99
                Debug.Print "2", gfld
                fctr = fctr + 1
                FSO.MoveFolder gfld, strFPath1 & "\"
            Next
        End If
    Next
    Set FSO = Nothing
    MsgBox ("移動完了フォルダ数=" & fctr - ectr & " 移動不可フォルダ数=" & ectr)
    If errmsg <> "" Then
        MsgBox ("以下のフォルダは既に同名フォルダが移動先に存在しますので移動されませんでした。" & vbLf & errmsg)
    End If
    Exit Sub
ERROR99:
    ectr = ectr + 1
    errmsg = errmsg & gfld & vbLf
    Resume Next
End Sub

Comments

[seiya811]

返信が遅くなり申し訳ありません。

動作確認をしたところ、希望通りの処理が出来ました！
メッセージボックスやエラー処理も追加していただき、
非常に使いやすくなりました！
ありがとうございます！

Answer 2

私の場合、 * を使わないようにします。
あまり美しくないですが、下記のよう書き換えてみました。

'「画像」フォルダに移動
Dim FSO As FileSystemObject
Set FSO = New FileSystemObject

Dim FSOfolder As Folder

For Each FSOfolder In FSO.GetFolder(ThisWorkbook.Path & "\フォルダA\画像").SubFolders
    Call FSO.MoveFolder(ThisWorkbook.Path & "\フォルダA\画像\" & FSOfolder.Name, ThisWorkbook.Path & "\画像\")
Next FSOfolder

For Each FSOfolder In FSO.GetFolder(ThisWorkbook.Path & "\フォルダB\画像").SubFolders
    Call FSO.MoveFolder(ThisWorkbook.Path & "\フォルダB\画像\" & FSOfolder.Name, ThisWorkbook.Path & "\画像\")
Next FSOfolder

For Each FSOfolder In FSO.GetFolder(ThisWorkbook.Path & "\フォルダC\画像").SubFolders
    Call FSO.MoveFolder(ThisWorkbook.Path & "\フォルダC\画像\" & FSOfolder.Name, ThisWorkbook.Path & "\画像\")
Next FSOfolder

Set FSO = Nothing

＜追記＞
フォルダ名が固定でないことを踏まえ、For Each 構文の多重ループを使用してみました。
その後、移動先に同一フォルダ名が存在する場合のエラー回避処理を追加しました。
動作確認をしていませんが、参考にしてください。

'「画像」フォルダに移動
Dim FSO As FileSystemObject
Set FSO = New FileSystemObject

Dim fol1 As Folder, fol2 As Folder, fol3 As Folder

For Each fol1 In FSO.GetFolder(ThisWorkbook.Path).SubFolders
    If fol1.Name <> "画像" Then
        For Each fol2 In fol1.SubFolders
            For Each fol3 In fol2.SubFolders
                If FSO.FolderExists(ThisWorkbook.Path & "\画像\" & fol3.Name) Then
                    MsgBox "同一フォルダ名がありますので処理をスキップします。"
                Else
                    FSO.MoveFolder CStr(fol3), ThisWorkbook.Path & "\画像\"
                End If
            Next fol3
        Next fol2
    End If
Next fol1

Set FSO = Nothing

Comments

[seiya811]

早速のご回答ありがとうございます。

説明がわかりづらく申し訳ありません。
「A」「B」「C」とした部分は毎回内容が変わります。

カメラマンに写真を撮っていただき、画像を納品していただくのですが、
例えば猫の写真をとった場合は「猫」→「画像」→「cat」で納品され、
犬の写真をとった場合は「犬」→「画像」→「dog」で納品される、といった形です。

[TanakaHiroaki]

「A」「B」「C」を変数にすることで解決できます。
コードを美しくしたければ、for Each 構文を多重ループにする方法が
よいと思います。
私が記載したコードを参考にご自身で考えてみてください。

[seiya811]

ご回答ありがとうございます。
参考にさせていただきます。

[TanakaHiroaki]

For Each 構文の多重ループを使用したコードを追記しました。