メディア掲載: レバテックフリーランス様のサイトで当ブログが紹介されました

【Excel】ファイル名一括変更・ファイル一括移動ツール

仕事でも趣味でも、PC上のファイル名を一括変更したい時、たまにありますよね?

手動で一つ一つ変更すると日が暮れてしまう・・・
普段から使い慣れているExcelで、効率的にファイル名を変更したいなぁ・・・

と思ったので、マクロを作成してみました。
同じ悩みを持たれている方のお役に立てば・・・と思い、このツールを公開させていだきます。

*当ツールの利用によって、ご利用者様、または第三者に損害・トラブル等が発生した場合でも、製作者は一切の責任を負いません。自己責任の上でのご利用をお願いいたします。

ファイル名一括変更・ファイル一括移動ツールでできること

ツール名のとおりですが、Excel上で複数ファイルのファイル名を一括変更したり、ファイルを一括移動したりすることができます。

動作イメージ

ダウンロード

ファイル名一括変更&一括移動ツール(zip形式)

使い方

ダウンロード ~ ファイルを開く

ダウンロードしたzipファイルを展開し、ファイル名一括変更一括移動ツール_微風_on_the_web.xlsmを開きます。

下記のようなメッセージが表示された場合は、編集を有効にするコンテンツの有効化をクリックしてください。

保護ビュー
マクロが無効にされました

対象のファイルが格納されているフォルダを選択する

画面左上の変更前ファイルリスト作成ボタンを押下します。

変更前ファイルリスト作成ボタンを押下

ファイルが格納されているフォルダを選択します

対象のフォルダを選択

確認メッセージが表示されますのではいまたはいいえを選択してください。

*初回は、はいでもいいえでも動作は変わりません。2つ目以降のフォルダを選択した際に、既存のファイル一覧の情報に追加する場合ははい、既存のファイル一覧は削除する場合はいいえを選択してください。

確認ダイアログ

選択したフォルダ内にあるファイルの情報が表示されます。

ファイル情報が一覧表示された

変更後の情報を入力する

次に、変更後のファイル情報(ファイルの移動先、変更後の名前)を入力します。

・場所を移動するファイルは、移動先フォルダ欄に移動先のパスを入力
・ファイル名を変更するファイルは、変更後ファイル名欄に変更後の名前を入力
* 移動しつつ名前も変更する場合は、両方に入力
* 何もしないファイルは、何も入力しない。(もしくは行削除しておく)

変更後ファイル情報の入力イメージ

一括処理を実行する

画面右上の名称一括変更&移動処理ボタンを押下します。

確認ダイアログ
OKを押下

処理が行われ、実行結果が表示されます。

一括変更・移動の結果

説明は以上です。

参考:ソースコード

参考までに、拙いですが・・・ソースコードです。
改善点のアドバイス等ございましたら、是非コメント欄などでお知らせください。

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

コメント

  1. やまと より:

    移動先フォルダが存在しない時に、そのフォルダを生成することができたりしたらすごくうれしいです。できないでしょうか?

タイトルとURLをコピーしました