このサイトはCocoonを使っています。現在「ミックスブルー [作者: y.hiroaki氏]」スキンを適用中です(^^)/

【ExcelVBA】全ファイルを再帰処理でルートフォルダに移動

スポンサーリンク

大量のファイルを複数のサブフォルダ(例えば日付ごとなど)に分けて保存している場合があると思いますが、まとめて処理したい場合にどうしていますか?

いちいちフォルダを見て回るより、一か所にまとめて見た方が処理を効率的なのではないでしょうか。
ただ、同じファイル名があるケースって結構あるのではないでしょうか。なので、今回の記事ではサブフォルダに分けられたファイルをすべてルートフォルダに移動させる処理移動先に同一ファイル名があった場合の処理方法について書いていきたいと思います

全てのファイルをFileSystemObjectによる再起処理でルートフォルダに移動させます
ファイル名が重複している場合の処理も解説します

スポンサーリンク

再起処理のロジックを確認

フローチャートで確認

・再帰はプロシージャーの処理中に同一プロシージャー(自分自身)を再度呼び出す処理のこと
・処理数が大量の場合スタックする可能性があるので注意が必要です

再帰処理している部分の説明

・フロー左側の「ファイル移動モジュールを呼び出し」のところから始まり
・次にサブフォルダがあるかどうかを確認します
・サブフォルダが存在している場合に「ファイル移動モジュールを呼び出し」に再帰します
・再帰はサブフォルダの存在がなくなるまで繰り返していきます
・そしてサブフォルダの無いフォルダに到達したらファイルの移動処理に進みます

全ファイルを再起処理でルートフォルダに移動するコード

・それでは、VBAコードを紹介します
・コードは「FileSystemObject」を使用しますが参照設定していなくても動作するように
 実行時バインディングでコーディングしています

スタート部分のコード

Option Explicit
'サブフォルダ内のファイルを全てルートに移動する
Sub subFolderCut()
    Dim rootPath As String
        
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "ルートフォルダを選択"
        .AllowMultiSelect = False
        'キャンセルされたら抜ける
        If .Show = False Then
            MsgBox "フォルダが選択されませんでした"
            Exit Sub
        End If
        rootPath = .SelectedItems(1)
    End With
    
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim rootFld As Object
    Set rootFld = FSO.GetFolder(rootPath)
    
    'サブフォルダの存在確認
    If rootFld.SubFolders.Count <> 0 Then
        'サブフォルダ内ファイル移動処理へ
        Call MoveFiles(rootFld, rootPath)
    Else
        MsgBox "サブフォルダはありません!"
    End If
  MsgBox "ファイルの移動処理終了!"
    Set FSO = Nothing
    Set rootFld = Nothing
End Sub

・6~15行目は、フォルダ選択ダイアログを呼び出す処理です
23行目で、ルートフォルダ内のサブフォルダ数をカウントして存在の有無を確認しています。「0」の場合サブフォルダが無いのでファイルを移動する必要がないので処理を終了するようにしています

再帰処理部分とファイルを移動する処理のコード

'再起処理で全ファイル移動する引数(フォルダーObject, rootPath文字列)
Sub MoveFiles(Fld As Object, rootPath As String)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim f As Variant
    Dim subFld As Object
    
    'フォルダー内にサブフォルダーがなくなるまで再帰する
    For Each subFld In Fld.SubFolders
        Call MoveFiles(subFld, rootPath) '再帰処理へ
        subFld.Delete '処理が終わったフォルダーを削除する
    Next
    
    Dim fname As String
    Dim attNo As String
    Dim ext As String
    Dim pos As Long
    'ファイル移動処理
    For Each f In Fld.Files
        fname = ""  '一旦初期化する
        On Error GoTo Err_FileExist
        Call FSO.MoveFile(f, rootPath & "\" & fname)
        On Error GoTo 0
    Next
    Set FSO = Nothing
    Exit Sub
    
Err_FileExist:
    Select Case Err.Number
        Case 58   'ファイル名重複エラーの場合(FileExist)
            If fname = "" Then
                fname = f.Name 'ファイル名取得
            End If
            '拡張子部分をカット
            ext = Right(fname, Len(fname) - InStrRev(fname, ".") + 1)
            fname = Left(fname, Len(fname) - Len(ext))
            pos = InStrRev(fname, "_")  '"_"の位置確認
            If pos > 0 Then             '"_"以下の数字部分を見る
                attNo = Right(fname, Len(fname) - pos)
                If IsNumeric(attNo) Then
                    attNo = Val(attNo) + 1 '数値をインクリメント
                    fname = Left(fname, pos) & attNo & ext '付け替える
                Else
                    fname = fname & "_1" & ext '無い場合は"_1"を付ける
                End If
            Else
                fname = fname & "_1" & ext '"_"が無い場合"_1"を付ける
            End If
            Resume
        Case Else   'その他のエラーの場合はエラー表示して中断
            Err.Raise Err.Number, , Err.Description
        End Select
End Sub

【再帰処理部分の説明】
8~12行目が「再帰処理」部分です
・10行目の「Call MoveFiles(subFld, rootPath)」で自分自身を再度呼び出しています
・これを繰り返すことで、最深部のフォルダに到達できるわけです
最深部のフォルダに到達できて初めて、ファイル移動処理に移ります
【ファイル移動部分の説明】
・22行目でファイルを移動するコード「Call FSO.MoveFile」を実行します
エラーが無ければ移動は完了ですが、エラーがあった場合は28行目にジャンプします
・エラー番号で処理を分岐しています。エラー番号「58」以外は処理を中止します
エラー番号「58」のファイル名重複エラーの場合の処理が31行目以降の処理です
・ファイル名が重複している場合は、ファイル名に「_番号」を付加します
・例えば、ファイル名に「_1」がついていた場合、数字をインクリメントします
・この場合は「_2」を付けます。「_2」の場合は「_3」となります
・ファイル名変更後に「resume」でエラー発生個所の22行目に戻ります
・この処理をエラーがなくなるまで繰り返していきます
・11行目ではサブフォルダ内ファイルの移動が全て終わっているはずなので、
 そのサブフォルダを削除します
・この一連の処理をすべてのサブフォルダがなくなるまで繰り返していきます

・結構複雑な処理ですよね
・これを同じように手動で処理することを考えると気が遠くなります(^^;
・是非試してみてくださいね。ただし、失敗しても責任はとれませんので、
試す場合は、バックアップを取ったうえで一度検証してから本実行してね』

まとめ(おわりに)

まとめと感想など

・再帰処理では処理数が大量の場合スタックする可能性があるので注意が必要です
・今回のコードは、ルートフォルダを指定してその中のサブフォルダ内のファイルを
 移動する処理です
・移動する場所を指定する方法ですが、保存先を指定する方法へも改変できます
・ファイル名の重複があった場合の処理は、ファイル名に番号を付ける処理にしています
 が、必要なければ「上書き」してしまう処理などにも変更可能です

今後の記事について

今回の記事はいかがだったでしょうか。お役に立てたなら幸いです(^^;
是非!サンプルがありますので使ってみてください(^^)/


【今後の記事内容はどうしようかなぁ・・・】
・前項で記した今回の記事の改変も検討します
・ファイル名を変更する方法も検討していきたいです
・高速化した「VlookUp関数」のVBAでの活用法を再検討してみたいと思います
・その他「小ネタいろいろ」などなど・・・・・
・今後これらのどれかについて記事にしていきたいと思います。ご期待ください(^^)/

サンプルファイルをダウンロードできます(下記リンク先へ)

記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください