仕事でも趣味でも、PC上のファイル名を一括変更したい時、たまにありますよね？
手動で一つ一つ変更すると日が暮れてしまう・・・
普段から使い慣れているExcelで、効率的にファイル名を変更したいなぁ・・・
と思ったので、マクロを作成してみました。
同じ悩みを持たれている方のお役に立てば・・・と思い、このツールを公開させていだきます。
＊当ツールの利用によって、ご利用者様、または第三者に損害・トラブル等が発生した場合でも、製作者は一切の責任を負いません。自己責任の上でのご利用をお願いいたします。
ファイル名一括変更・ファイル一括移動ツールでできること
ツール名のとおりですが、Excel上で複数ファイルのファイル名を一括変更したり、ファイルを一括移動したりすることができます。
ダウンロード
ファイル名一括変更＆一括移動ツール（zip形式）
使い方
ダウンロード ～ ファイルを開く
ダウンロードしたzipファイルを展開し、ファイル名一括変更一括移動ツール_微風_on_the_web.xlsmを開きます。
下記のようなメッセージが表示された場合は、編集を有効にする、コンテンツの有効化をクリックしてください。
対象のファイルが格納されているフォルダを選択する
画面左上の変更前ファイルリスト作成ボタンを押下します。
ファイルが格納されているフォルダを選択します
確認メッセージが表示されますのではいまたはいいえを選択してください。
＊初回は、はいでもいいえでも動作は変わりません。2つ目以降のフォルダを選択した際に、既存のファイル一覧の情報に追加する場合ははい、既存のファイル一覧は削除する場合はいいえを選択してください。
選択したフォルダ内にあるファイルの情報が表示されます。
変更後の情報を入力する
次に、変更後のファイル情報（ファイルの移動先、変更後の名前）を入力します。
・場所を移動するファイルは、移動先フォルダ欄に移動先のパスを入力
・ファイル名を変更するファイルは、変更後ファイル名欄に変更後の名前を入力
＊ 移動しつつ名前も変更する場合は、両方に入力
＊ 何もしないファイルは、何も入力しない。（もしくは行削除しておく）
一括処理を実行する
画面右上の名称一括変更＆移動処理ボタンを押下します。
処理が行われ、実行結果が表示されます。
説明は以上です。
参考：ソースコード
参考までに、拙いですが・・・ソースコードです。
改善点のアドバイス等ございましたら、是非コメント欄などでお知らせください。
Option Explicit
Const headerR As Long = 4
Sub フォルダ選択()
Application.ScreenUpdating = False
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim ws As Worksheet: Set ws = Worksheets("main")
Dim folder
' フォルダを選択
If Application.FileDialog(msoFileDialogFolderPicker).Show = False Then Exit Sub
folder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
' ユーザーに処理方法の確認
Dim rc
rc = MsgBox("指定したフォルダのファイル一覧を取得します。" & vbCrLf & _
vbCrLf & _
"現在のファイル一覧は残したまま、その後ろに追加しますか？" & vbCrLf & _
"※ 「いいえ」を選択した場合、現在の一覧をクリアして、新たに一覧を作成します" _
, vbYesNoCancel)
If rc = vbCancel Then
MsgBox ("処理をキャンセルしました。")
Exit Sub
ElseIf rc = vbNo Then
'既存データクリア
ws.Rows(headerR + 1 & ":" & Rows.Count).ClearContents
End If
' ファイル情報一覧を作成
Dim fileObj As Object
Dim i As Long: i = 1
Dim endR: endR = Cells(Rows.Count, "A").End(xlUp).Row
For Each fileObj In fso.GetFolder(folder).Files
If (fileObj.Attributes And 2) Or (fileObj.Attributes And 4) Or (fileObj.Attributes And 8) Or (fileObj.Attributes And 16) Then
'2:隠しファイル 4:システムファイル 8:ディスクドライブボリュームラベル 16:フォルダまたはディレクトリ はスキップ
Else
'ファイル一覧に追記
ws.Cells(endR + i, "A").Value = folder
ws.Cells(endR + i, "B").Value = fso.GetBaseName(fileObj)
ws.Cells(endR + i, "C").Value = fso.GetExtensionName(fileObj)
ws.Cells(endR + i, "D").Value = fileObj.Size
ws.Cells(endR + i, "E").Value = fileObj.DateCreated
ws.Cells(endR + i, "F").Value = fileObj.DateLastModified
i = i + 1
End If
Next
End Sub
Sub ファイル移動名前変更()
Application.ScreenUpdating = False
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim ws As Worksheet: Set ws = Worksheets("main")
' ユーザーに処理方法の確認
Dim rc
rc = MsgBox("ファイル名一括変更 & ファイル一括移動処理を行います。よろしいですか？", vbOKCancel)
If rc = vbCancel Then
MsgBox ("処理をキャンセルしました。")
Exit Sub
End If
' 変数宣言
Dim errFlg As String
Dim procFlg As String
Dim oldFileName As String
Dim oldFolderPath As String
Dim oldFileType As String
Dim oldFileFullPath As String
Dim newFolderPath As String
Dim newFileName As String
Dim i As Long
Dim endR: endR = ws.Range("A3").CurrentRegion.Rows.Count + ws.Range("A3").CurrentRegion.Row - 1
Dim successCnt As Long: successCnt = 0
Dim failureCnt As Long: failureCnt = 0
Dim skipCnt As Long: skipCnt = 0
' ファイル名一括変更 & ファイル一括移動処理
On Error GoTo printError
For i = (headerR + 1) To endR
'フラグリセット
errFlg = "0"
procFlg = "0"
'行データ取得
oldFileName = ws.Cells(i, "B").Value
oldFolderPath = ws.Cells(i, "A").Value
oldFileType = ws.Cells(i, "C").Value
oldFileFullPath = oldFolderPath & "\" & oldFileName & "." & oldFileType
newFolderPath = ws.Cells(i, "H").Value
newFileName = ws.Cells(i, "I").Value
'ファイル名変更
If newFileName <> "" And newFileName <> oldFileName Then
procFlg = "1"
fso.getfile(oldFileFullPath).Name = newFileName & "." & oldFileType
If errFlg = "1" Then GoTo continue
'ファイル移動処理用に旧フルパスのファイル名を変更
oldFileFullPath = oldFolderPath & "\" & newFileName & "." & oldFileType
End If
'ファイル移動
If newFolderPath <> "" And newFolderPath <> oldFolderPath Then
procFlg = "1"
fso.MoveFile oldFileFullPath, newFolderPath & "\"
If errFlg = "1" Then
'名称変更していた場合は戻す
If newFileName <> "" And newFileName <> oldFileName Then
fso.getfile(oldFileFullPath).Name = oldFileName & "." & oldFileType
End If
GoTo continue
End If
End If
'実行結果記載
If procFlg = "1" Then
ws.Cells(i, "J").Value = "成功"
successCnt = successCnt + 1
Else
ws.Cells(i, "J").Value = "－－"
skipCnt = skipCnt + 1
End If
continue:
If errFlg = "1" Then failureCnt = failureCnt + 1
Next
' 結果メッセージ
Application.ScreenUpdating = True
MsgBox ("処理が完了しました。" & vbCrLf & _
"--------------------" & vbCrLf & _
"成功：" & successCnt & " 件" & vbCrLf & _
"失敗：" & failureCnt & " 件" & vbCrLf & _
"処理なし：" & skipCnt & " 件" & vbCrLf)
Exit Sub
' エラーハンドリング
printError:
ws.Cells(i, "J").Value = "失敗：" & Err.Description
errFlg = "1"
Resume Next
End Sub
コメント
移動先フォルダが存在しない時に、そのフォルダを生成することができたりしたらすごくうれしいです。できないでしょうか？
フォルダ名の一括置換も同様にできると嬉しいです！