フォルダ内ファイル名一括変更Excelマクロ

俺用メモですが、ご自由にお使いください。苦情は受け付けません。

フォルダ内のファイル名を一括で付け替えるExcelマクロです。
サブフォルダは処理しません。

リストにするのが楽なのでExcelで作ってますが、なんのファイルでもリネームできます。
.docでもtxtとか、mp3とかでも処理できます。
ファイルシステムはVBAだからね。Windowsなら同じなわけです。
エクセルだとオートフィルが使えるから、新ネームで連番ふるのとかも楽だしね、それでExcelで作ってます。

Windows7,8,10、Excel2007あたり以上なら大体動作するはずです。
ファイル形式違うけど、マクロのコード自体は2003でも動作するはず。
Macは知らん。

ざっくりなので、あんまりエラー回避を組んでません。
一応ファイル名の重複チェックとか禁則文字チェックあるけど、一気にチェックしないで1個該当する度に止まるぞ。
（新ファイル名を直せってダイアログ出る時点ではリネームしてないので、直して再度リネームボタン押してください）

ファイルはこれ↓
drive.google.com

自分でマクロを組む場合は

１シート目をリストとかの処理に使ってるので、表組はこの通りに組んでください。
フォルダはB2セル、ファイル名リストは9行目から。
H列は禁則文字を1行目から入れてます。
注意書きは好きにしてくれ。

マクロのソースコードは下記。

Sub フォルダ名取得()

'前のフォルダ名消去
    Worksheets(1).Range("B2").ClearContents
    
'前のファイルリスト消去
    Range("A9").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
    With Selection.Font         '文字色黒に戻す
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With

'フォルダ名取得
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択して　OK　をクリック"
        If .Show Then
            Cells(2, 2) = .SelectedItems(1)
        Else
        End If
    End With
    
End Sub

Sub ファイル名取得()

Dim FSO As Object
Dim 拡張子 As String
Dim 旧名 As String
Dim フォルダパス As String
Dim ファイル名, 処理行

    フォルダパス = Range("B2").Value
    
    ファイル名 = Dir(フォルダパス & "\*.*")
    
    処理行 = 9 - 1
    
'無指定エラー回避
    If Range("B2").Value = Empty Then
        MsgBox "Error フォルダ指定してください", vbExclamation
        Exit Sub
    Else
    End If

'ファイル名取得
    Do While ファイル名 <> ""
        処理行 = 処理行 + 1
        Set FSO = CreateObject("Scripting.FileSystemObject")
        拡張子 = FSO.getextensionname(ファイル名)
        旧名 = FSO.getbasename(ファイル名)
        Set FSO = Nothing
        
        Range("B" & 処理行).Value = 旧名
        Range("A" & 処理行).Value = 拡張子
        
        ファイル名 = Dir()
    Loop

'ファイル名B列基準でソート
    Range("A9").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Sort Key1:=Range("B9"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
    Range("C9").Select  'セル位置を新ネームに
    
    MsgBox "ファイル名取得終了しました"
        
End Sub

Sub リネーム()

Dim フォルダパス As String
Dim 旧名, 新名, 処理行, 末行
Dim i As Long   '禁則文字チェック用変数

'フォント色黒に戻す
    Worksheets("Sheet1").Range("A9").CurrentRegion.Select
    Selection.Font.ColorIndex = 1
    Range("C9").Select
    
'末行判定
    If Range("A10").Value = 0 Then
        末行 = 9
    Else
        末行 = Range("A9").End(xlDown).Row
    End If
    
'D列削除
    Range("D9:D" & 末行).ClearContents

'ファイル名禁則文字チェック
    Dim c As Object
    Dim 禁則文字 As String
    Dim 検索結果 As String
    
    i = 1
    Do Until Range("H" & i).Value = ""
        禁則文字 = Range("H" & i).Value
        With Worksheets(1).Range("C9:C" & 末行)
            Set c = .Find(What:=禁則文字, LookIn:=xlValues, lookat:=xlPart, _
                SearchOrder:=xlByColumns, MatchByte:=False)
        
            If Not c Is Nothing Then
                検索結果 = c.Address
            
                Do
                    c.Font.ColorIndex = 3
                    MsgBox "ファイル名に\/?:*<>|は使用できません", vbExclamation
                    Exit Sub
                    
                        Set c = .FindNext(c)
                            If c.Address + 検索結果 Then Exit Do
                Loop
                
            End If
        End With
        
        i = i + 1
    Loop
    
'新ファイル名重複チェック
    For 処理行 = 9 To 末行
        If WorksheetFunction.CountIf(Range("B9:C" & 末行), Cells(処理行, 3)) > 1 Then
            Cells(処理行, 3).Font.ColorIndex = 3    '重複は文字を赤色に
            
            MsgBox "新ファイル名が重複しています。違う名前を指定してください。", vbExclamation
            Exit Sub
        End If
    Next 処理行
    
'フォルダとファイル名規定
    フォルダパス = Range("B2").Value
    処理行 = 9

'リネーム処理
    Do Until Range("B" & 処理行).Value = ""
    
        旧名 = フォルダパス & "\" & Range("B" & 処理行).Value & "." & Range("A" & 処理行).Value
        新名 = フォルダパス & "\" & Range("C" & 処理行).Value & "." & Range("A" & 処理行).Value
    
    '新ネーム未指定だったらD列にメッセージを入れて処理をスキップ
        If Range("C" & 処理行).Value = "" Then
            Range("D" & 処理行).Value = "新ネーム未指定。スキップしました"
        Else
            Name 旧名 As 新名
        End If
        
        処理行 = 処理行 + 1
    Loop
    
    MsgBox "リネーム終了"

End Sub