質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.91%

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

解決済

回答 2

投稿

  • 評価
  • クリップ 0
  • VIEW 4,040

score 15

 前提・実現したいこと

「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です。
不足情報、不明点等御座いましたらお申し付けください。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

+2

あなたが作成したマクロに多少手を加えました。
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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/10/21 16:42

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

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

    キャンセル

0

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

'「画像」フォルダに移動
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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/10/20 11:21

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

    キャンセル

  • 2018/10/20 11:36 編集

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

    キャンセル

  • この投稿は削除されました

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.91%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る