同じ名前のフォルダがある場所にフォルダを移動すると、
こんな表示が出て、同名のファイルたちを統合できます。
こんな処理をVBAでやりたいとなった場合、
残念ながらこれを一発でやる機能は用意されていません。
よって、
- フォルダ内のすべてのファイルをループ
- 移動先に同名ファイルがあるか判定しスキップ/上書きして移動
- すべて終わったら元フォルダを削除
という手順で地道に実行する必要があります。
それを実行するコードを紹介します。
今回は「MoveFolderメソッド」でフォルダ移動のコードを書きましたが、
「CopyFolderメソッド」でも全く同じ処理ができます。
元フォルダを残してフォルダを統合したい場合は、
本記事のコードを単純に置換してご利用ください。
なお、本コードにはFileSystemObject(以下FSO)を使用します。
FSOについての解説はこちらを参照ください。
www.limecode.jp
- 移動先にファイルがあればスキップしてフォルダを統合する
- 移動先のファイルを上書きしてフォルダを統合する
- 上書き・スキップを各個判定してフォルダを統合する
- 同名のファイルがあればファイル名に連番を付けてフォルダを統合する
移動先にファイルがあればスキップしてフォルダを統合する
上書きはせずスキップ(元フォルダのファイルは削除)する場合がこちらです。
Sub フォルダを移動して統合する_スキップ版() Dim FSO As New FileSystemObject Dim Fromフォルダ As Folder Set Fromフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ1\対象フォルダ") Dim Toフォルダ As Folder Set Toフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ2\対象フォルダ") ' 移動元フォルダにサブフォルダがあれば警告してExit If Fromフォルダ.SubFolders.Count > 0 Then MsgBox "サブフォルダがあるフォルダには実行できません。" Exit Sub End If ' 移動元フォルダのすべてのファイルをループ Dim Fromファイル As File For Each Fromファイル In Fromフォルダ.Files ' 移動先に同名ファイルがない場合のみ移動を実行 If FSO.FileExists(Toフォルダ.Path & "\" & Fromファイル.Name) = False Then Fromファイル.Move Toフォルダ.Path & "\" End If Next ' 最後に移動元フォルダを削除 Fromフォルダ.Delete End Sub
※ FSOの基本に忠実なコードのため解説は割愛します。
移動先のファイルを上書きしてフォルダを統合する
移動時に上書きを行う場合はちょっとした小ワザが使えます。
MoveFolderメソッドには「上書き」の設定はないのですが、
CopyFolderメソッドには第3引数「OverWriteFiles」が用意されています。
これでは移動ではなくコピーなのですが、
コピー後にコピー元を消すことで疑似的に移動を実現できます。
Sub フォルダを移動して統合する_上書き版() Dim FSO As New FileSystemObject Dim Fromフォルダ As Folder Set Fromフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ1\対象フォルダ") Dim Toフォルダ As Folder Set Toフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ2\対象フォルダ") ' 移動元フォルダにサブフォルダがあれば警告してExit If Fromフォルダ.SubFolders.Count > 0 Then MsgBox "サブフォルダがあるフォルダには実行できません。" Exit Sub End If ' 上書きコピーしてから元のフォルダを消す FSO.CopyFolder Fromフォルダ.Path, Toフォルダ.Path, OverWriteFiles:=True Fromフォルダ.Delete End Sub
ものすごくコードが短くなりましたね。
なお、この方法でOverWriteFilesをFalseにすれば、
スキップ版も実行できる気がしますが残念ながらできません。
OverWriteFilesをFalseにした場合はスキップではなくエラーになり、
On Error Resume Nextを設定してもCopyが実行されなくなるだけです。
※ 同名ファイルだけスキップして他はCopyという器用な動きには当然なりません。
よってこの手法が使えるのは「移動元で上書き」する場合のみです。
この条件を勘違いしそうで怖いという場合は、
小ワザに頼らないFor Each版も載せておきますのでこちらを採用して下さい。
Sub フォルダを移動して統合する_上書き版() Dim FSO As New FileSystemObject Dim Fromフォルダ As Folder Set Fromフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ1\対象フォルダ") Dim Toフォルダ As Folder Set Toフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ2\対象フォルダ") ' 移動元フォルダにサブフォルダがあれば警告してExit If Fromフォルダ.SubFolders.Count > 0 Then MsgBox "サブフォルダがあるフォルダには実行できません。" Exit Sub End If ' 移動元フォルダのすべてのファイルをループ Dim Fromファイル As File For Each Fromファイル In Fromフォルダ.Files ' 移動先に同名ファイルがあれば削除 If FSO.FileExists(Toフォルダ.Path & "\" & Fromファイル.Name) Then FSO.DeleteFile Toフォルダ.Path & "\" & Fromファイル.Name End If ' 移動を実行 Fromファイル.Move Toフォルダ.Path & "\" Next ' 最後に移動元フォルダを削除 Fromフォルダ.Delete End Sub
上書き・スキップを各個判定してフォルダを統合する
続いてファイルそれぞれで上書きを判定する場合です。
サンプルとして「更新日が後のファイルを採用」するコードを記載します。
これは手作業にはできない処理になりますね。
Sub フォルダを移動して統合する_更新日判定版() Dim FSO As New FileSystemObject Dim Fromフォルダ As Folder Set Fromフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ1\対象フォルダ") Dim Toフォルダ As Folder Set Toフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ2\対象フォルダ") ' 移動元フォルダにサブフォルダがあれば警告してExit If Fromフォルダ.SubFolders.Count > 0 Then MsgBox "サブフォルダがあるフォルダには実行できません。" Exit Sub End If ' 移動元フォルダのすべてのファイルをループ Dim Fromファイル As File For Each Fromファイル In Fromフォルダ.Files ' 移動先に同名ファイルがない場合は移動を実行 If FSO.FileExists(Toフォルダ.Path & "\" & Fromファイル.Name) = False Then Fromファイル.Move Toフォルダ.Path & "\" ' 同名ファイルがある場合 Else Dim Toファイル As File Set Toファイル = FSO.GetFile(Toフォルダ.Path & "\" & Fromファイル.Name) ' 移動元の更新日が大きい場合は移動先ファイルを削除してから移動 If Fromファイル.DateLastModified > Toファイル.DateLastModified Then Toファイル.Delete Fromファイル.Move Toフォルダ.Path & "\" End If End If Next ' 最後に移動元フォルダを削除 Fromフォルダ.Delete End Sub
同名のファイルがあればファイル名に連番を付けてフォルダを統合する
最後にすべてのファイルを残すために、
ファイル名が重複しないよう連番付きにリネームするパターンです。
これも手作業にはできない処理になりますね。
Sub フォルダを移動して統合する_同名は連番付与版() Dim FSO As New FileSystemObject Dim Fromフォルダ As Folder Set Fromフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ1\対象フォルダ") Dim Toフォルダ As Folder Set Toフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ2\対象フォルダ") ' 移動元フォルダにサブフォルダがあれば警告してExit If Fromフォルダ.SubFolders.Count > 0 Then MsgBox "サブフォルダがあるフォルダには実行できません。" Exit Sub End If ' 移動元フォルダのすべてのファイルをループ Dim Fromファイル As File For Each Fromファイル In Fromフォルダ.Files ' 移動先に同名ファイルがなくなるまで連番を付与 If FSO.FileExists(Toフォルダ.Path & "\" & Fromファイル.Name) Then Dim i As Long: i = 2 Do Dim リネーム名 As String リネーム名 = FSO.GetBaseName(Fromファイル) & " (" & i & ")." _ & FSO.GetExtensionName(Fromファイル) If FSO.FileExists(Toフォルダ.Path & "\" & リネーム名) = False Then Exit Do i = i + 1 Loop Fromファイル.Name = リネーム名 End If ' 移動を実行 Fromファイル.Move Toフォルダ.Path & "\" Next ' 最後に移動元フォルダを削除 Fromフォルダ.Delete End Sub
なお、この「同名ファイルがなくなるまで連番を付与する」処理は、
Workbook.SaveAsなどでも利用するため関数化すると便利です。
Public FSO As New FileSystemObject Sub フォルダを移動して統合する_同名は連番付与版() Dim Fromフォルダ As Folder Set Fromフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ1\対象フォルダ") Dim Toフォルダ As Folder Set Toフォルダ = FSO.GetFolder("C:\Users\○○\Desktop\親フォルダ2\対象フォルダ") ' 移動元フォルダにサブフォルダがあれば警告してExit If Fromフォルダ.SubFolders.Count > 0 Then MsgBox "サブフォルダがあるフォルダには実行できません。" Exit Sub End If ' 移動元フォルダのすべてのファイルをループ Dim Fromファイル As File For Each Fromファイル In Fromフォルダ.Files Fromファイル.Move Toフォルダ.Path & "\" _ & Get重複がないよう付番したファイル名(Fromファイル.Name, Toフォルダ.Path) Next ' 最後に移動元フォルダを削除 Fromフォルダ.Delete End Sub ' ファイル名に連番を付与する汎用関数 Function Get重複がないよう付番したファイル名(元ファイル名 As String, フォルダパス As String) As String Dim ベース名 As String: ベース名 = FSO.GetBaseName(元ファイル名) Dim 拡張子 As String: 拡張子 = FSO.GetExtensionName(元ファイル名) Dim 決定ファイル名 As String: 決定ファイル名 = 元ファイル名 If FSO.FileExists(フォルダパス & "\" & 決定ファイル名) Then Dim i As Long: i = 2 Do Dim リネーム名 As String 決定ファイル名 = ベース名 & " (" & i & ")." & 拡張子 If FSO.FileExists(フォルダパス & "\" & 決定ファイル名) = False Then Exit Do i = i + 1 Loop End If Get重複がないよう付番したファイル名 = 決定ファイル名 End Function
本体マクロの「Move」部分が1行になって非常に読みやすくなります。
かなり便利な関数ですので使ってみてください。
ついでですが、
Public FSO As New FileSystemObject
このようにPublic変数でFSOを宣言すれば、
この変数をすべてのプロシージャで使いまわせます。
これも便利な手法ですので覚えておきましょう。
www.limecode.jp
