Excel VBAでファイル拡張子を一括変更する方法｜プレビューと安全な実行手順

Option Explicit

' 対象を固定: 単一フォルダの txt → csv。内容の変換は行いません。
Private Const MAX_FILES As Long = 100
Private mPlan As Collection
Private mReport As Worksheet

Public Sub PreviewExtensionRename()
    Dim fso As Object, folder As Object, file As Object, seen As Object
    Dim plan As Collection, report As Worksheet, picker As FileDialog
    Dim folderPath As String, newPath As String, item As Variant
    Dim i As Long, skipped As Long
    On Error GoTo Failed
    Set mPlan = Nothing
    Set mReport = Nothing
    Set plan = New Collection
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set seen = CreateObject("Scripting.Dictionary")
    seen.CompareMode = vbTextCompare

    Set picker = Application.FileDialog(msoFileDialogFolderPicker)
    picker.Title = "原本ではなく、バックアップから作ったテスト用コピーを選択"
    If picker.Show <> -1 Then Exit Sub
    folderPath = picker.SelectedItems(1)
    If fso.GetParentFolderName(folderPath) = "" Then
        Err.Raise vbObjectError + 1000, , "ドライブ直下は選択できません。"
    End If
    Set folder = fso.GetFolder(folderPath)
    If (folder.Attributes And 1024) <> 0 Then
        Err.Raise vbObjectError + 1005, , "リンク先のフォルダは対象にできません。"
    End If

    ' 列挙中は名前を変更せず、変更予定をメモリに保存します。
    For Each file In folder.Files
        If StrComp(fso.GetExtensionName(file.Name), "txt", vbTextCompare) = 0 Then
            If (file.Attributes And 1031) <> 0 Then
                skipped = skipped + 1  ' 読み取り専用・隠し・システム・リンクは除外
            Else
                If fso.GetBaseName(file.Name) = "" Then
                    Err.Raise vbObjectError + 1001, , "名前本体が空です: " & file.Name
                End If
                newPath = fso.BuildPath(folderPath, fso.GetBaseName(file.Name) & ".csv")
                If fso.FileExists(newPath) Or fso.FolderExists(newPath) Then
                    Err.Raise vbObjectError + 1002, , "変更先が既に存在します: " & newPath
                End If
                If seen.Exists(newPath) Then
                    Err.Raise vbObjectError + 1003, , "変更先が重複します: " & newPath
                End If
                seen.Add newPath, True
                plan.Add Array(file.Path, newPath, CDbl(file.Size), CDbl(file.DateLastModified))
                If plan.Count > MAX_FILES Then
                    Err.Raise vbObjectError + 1004, , "対象が100件を超えました。フォルダを分けてください。"
                End If
            End If
        End If
    Next file
    If plan.Count = 0 Then
        MsgBox "対象は0件です。属性による除外: " & skipped & "件", vbInformation
        Exit Sub
    End If

    ' 既存シートを消さず、新規ブックに確認用一覧を作成します。
    Set report = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    report.Name = "拡張子変更予定"
    report.Columns("A:B").NumberFormat = "@"
    report.Range("A1:E1").Value = Array("変更前", "変更後", "サイズ(bytes)", "更新日時", "結果")
    For i = 1 To plan.Count
        item = plan(i)
        report.Cells(i + 1, 1).Value2 = item(0)
        report.Cells(i + 1, 2).Value2 = item(1)
        report.Cells(i + 1, 3).Value2 = item(2)
        report.Cells(i + 1, 4).Value2 = item(3)
        report.Cells(i + 1, 5).Value2 = "未実行"
    Next i
    report.Columns("D").NumberFormat = "yyyy-mm-dd hh:mm:ss"
    report.Columns("A:B").ColumnWidth = 60
    report.Columns("C:E").AutoFit
    report.Rows(1).Font.Bold = True
    Set mReport = report
    Set mPlan = plan
    MsgBox "プレビューのみ: " & plan.Count & "件。ファイルは変更していません。" & vbCrLf & _
           "属性による除外: " & skipped & "件。全行を確認し、一覧を保存してください。", vbInformation
    Exit Sub
Failed:
    Set mPlan = Nothing
    MsgBox "プレビューを中止しました。ファイルは変更していません。" & vbCrLf & _
           Err.Number & ": " & Err.Description, vbExclamation
End Sub

Public Sub ApplyExtensionRename()
    Dim fso As Object, plan As Collection, item As Variant
    Dim i As Long, done As Long, oldPath As String, newPath As String
    Dim errorText As String
    On Error GoTo Failed
    If mPlan Is Nothing Then
        MsgBox "先に PreviewExtensionRename を実行してください。", vbExclamation
        Exit Sub
    End If
    Set plan = mPlan
    Set mPlan = Nothing  ' 成功・中止・失敗のいずれでも、再実行には新しいプレビューが必要
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' 1件も変更する前に、一覧と全対象を再確認します。
    For i = 1 To plan.Count
        item = plan(i)
        oldPath = CStr(item(0))
        If CStr(mReport.Cells(i + 1, 1).Value2) <> CStr(item(0)) Or _
           CStr(mReport.Cells(i + 1, 2).Value2) <> CStr(item(1)) Then
            Err.Raise vbObjectError + 1010, , "一覧が編集されています。プレビューを作り直してください。"
        End If
        CheckRenameItem fso, item
    Next i
    If MsgBox("全行を確認し、原本・バックアップを別に保管しましたか？" & vbCrLf & _
              plan.Count & "件のテスト用コピーを改名します。形式変換はしません。" & vbCrLf & _
              "途中で失敗しても、完了分は自動では戻りません。", _
              vbYesNo + vbExclamation + vbDefaultButton2) <> vbYes Then Exit Sub

    For i = 1 To plan.Count
        item = plan(i)
        oldPath = CStr(item(0))
        newPath = CStr(item(1))
        CheckRenameItem fso, item  ' 各変更の直前にも再確認
        mReport.Cells(i + 1, 5).Value2 = "処理中（要確認）"
        Name oldPath As newPath
        done = done + 1
        mReport.Cells(i + 1, 5).Value2 = "改名済み"
    Next i
    MsgBox done & "件を改名しました。一覧を再保存し、内容を確認してください。", vbInformation
    Exit Sub
Failed:
    errorText = Err.Number & ": " & Err.Description
    Set mPlan = Nothing
    MsgBox "中止しました。改名完了: " & done & "件。自動復元はしません。" & vbCrLf & _
           "確認対象: " & oldPath & vbCrLf & errorText & vbCrLf & _
           "一覧と実際のファイル名を確認し、同じ操作を繰り返さないでください。", vbCritical
End Sub

Private Sub CheckRenameItem(ByVal fso As Object, ByVal item As Variant)
    Dim file As Object
    If Not fso.FileExists(CStr(item(0))) Then
        Err.Raise vbObjectError + 1020, , "元ファイルが見つかりません: " & item(0)
    End If
    If fso.FileExists(CStr(item(1))) Or fso.FolderExists(CStr(item(1))) Then
        Err.Raise vbObjectError + 1021, , "変更先が存在します: " & item(1)
    End If
    Set file = fso.GetFile(CStr(item(0)))
    If (file.Attributes And 1031) <> 0 Or CDbl(file.Size) <> CDbl(item(2)) Or _
       CDbl(file.DateLastModified) <> CDbl(item(3)) Then
        Err.Raise vbObjectError + 1022, , "元ファイルの状態が変わりました: " & item(0)
    End If
End Sub