Excel VBAでファイル名を一括変更する【実務で活用できる】

Option Explicit
Private Declare Function GetInputState Lib "USER32" () As Long  'DoEventsの代わり
'ファイル名変更（複数ファイルの選択可能で処理する）
Sub Open_File_NameEdit()
    Dim OpenFileName As Variant
    Dim PathName As String, fileName As String, pos As Long
    Dim kakuchosi As String '拡張子用
    Dim buf As String, buf2 As String
    Dim selectFName As Variant
    Dim xls As New Excel.Application
    Dim wb As Workbook, sh As Worksheet
    Dim ShName As String, pw As String
    Dim fnset As Long, intRow As Long, intCol As Long
    Dim i As Long, strMsg As String
    Dim strNewFileName As String
    
    On Error GoTo ErrHandler
    
    fnset = Range("I8")     'ファイル名指定フラグ
    pw = Range("I7")        'パスワード
    '不正ファイルリスト用スペースを初期化
    Range(Cells(17, 12), Cells(17, 12).End(xlDown)) = ""
    '対象ワークシート名等の設定を変数に入力
    fnset = fnset + 9
    ShName = Cells(fnset, 12) 'Range("L10")
    If ShName = "" Then
        MsgBox "ファイル名等の設定がありません！中止します！"
        Exit Sub
    End If
    intRow = Cells(fnset, 17)
    intCol = Cells(fnset, 18)
    strNewFileName = Cells(fnset, 8) 'Range("H10")
    'ファイル選択ダイアログを表示
    selectFName = Application.GetOpenFilename( _
            FileFilter:="Microsoft Excel,*.xls?, 全てのファイル, *.*", _
            FilterIndex:=1, _
            Title:="ファイルを選択してください（複数可）", _
            MultiSelect:=True)
    
    Call マクロ開始 '動作制御用
    '選択されたファイルに対する処理
    If IsArray(selectFName) Then
        '全てのファイルに繰り返し処理を行う
        For Each OpenFileName In selectFName
            pos = InStrRev(OpenFileName, "\")
            PathName = Left(OpenFileName, pos)      'パス部分
            fileName = Mid(OpenFileName, pos + 1)   'ファイル名
            pos = InStrRev(fileName, ".")
            kakuchosi = Mid(fileName, pos)          '拡張子
            'ファイルをリードオンリーで開き確認する
            Set wb = xls.Workbooks.Open(fileName:=PathName & fileName, _
                    Password:=pw, UpdateLinks:=0, ReadOnly:=True) ', _
                    CorruptLoad:=xlExtractData) '抽出モードで開く場合
            If GetInputState() Then DoEvents 'DoEventsを入れておく
            'シート内のセルからデータを取得する処理はここから
            On Error Resume Next
            Set sh = wb.Worksheets(ShName)
            If sh Is Nothing Then
                'シートが見つからない場合ファイル名を書き出す
                Cells(Rows.Count, 12).End(xlUp).Offset(1, 0) = _
                                    "シート名変更：" & fileName
                strMsg = "が変更されている"
                GoTo tugi
            Else
                buf2 = sh.Cells(intRow, intCol)
                If buf2 = "" Then
                    'セルにデータがない場合ファイル名を書き出す
                    Cells(Rows.Count, 12).End(xlUp).Offset(1, 0) = _
                                        "セルデータ不明：" & fileName
                    strMsg = "の内容が変更されている"
                    GoTo tugi
                Else
                    '置き換えが必要な場合設定とりあえずスペース削除
                    buf2 = Replace(Replace(buf2, " ", ""), "　", "")
                    'VLookupで設定取得
                    buf = Application.WorksheetFunction.VLookup(buf2, _
                                        Range("A:B"), 2, False)
                    If buf = "" Then
                        '設定を取得できない場合ファイル名を書き出す
                        Cells(Rows.Count, 12).End(xlUp).Offset(1, 0) = _
                                            "セルデータ不明：" & fileName
                        strMsg = "の内容が変更されている"
                        GoTo tugi
                    Else
                        On Error GoTo ErrHandler
                        wb.Close savechanges:=False 'ファイルを閉じる
                        Set xls = Nothing
                        Set wb = Nothing
                        Set sh = Nothing
                        '閉じたファイル名を変更
                        fileName = buf & "【" & buf2 & "】" & _
                                            strNewFileName & kakuchosi
                        Name OpenFileName As PathName & fileName
                    End If
                End If
            End If
            GoTo nextloop
tugi:
            MsgBox fileName & "はシート名「" & ShName & "」" & _
                    strMsg & "と思われるので処理できません！" & _
                    "正しく修正してから再度実行してください！"
            On Error GoTo ErrHandler
            wb.Close savechanges:=False 'ファイルを閉じる
            Set xls = Nothing
            Set wb = Nothing
            Set sh = Nothing
nextloop:
        Next
    Else
        Call マクロ終了
        MsgBox ("ファイルを選択しないで終了")
        Exit Sub
    End If
    Call マクロ終了
    MsgBox "選択したファイル名の変更が終了しました", _
                    vbOKOnly + vbInformation, "ファイル名一括変更"
    Exit Sub

ErrHandler:
    MsgBox "「" & fileName & "」の処理中にエラーが発生しました" & _
            vbCrLf & Err.Description, vbExclamation, "ファイル名一括変更"
    Set xls = Nothing
    Set wb = Nothing
    Set sh = Nothing
    Call マクロ終了
End Sub

'ファイル名一括変更【簡易版】
Sub Do_File_NameChange()
    Dim OpenFileName As String
    Dim PathName As String
    Dim i As Long, lnRow As Long
    Dim strNewFileName As String

    lnRow = Cells(1, 1).End(xlDown).Row
    If lnRow < 3 Then MsgBox "ファイルがセットされていません！中止します！": Exit Sub
    If Cells(1, 2).Value <> "" Then
        PathName = Cells(1, 2).Value & "\"
    Else: MsgBox "ファイルパスが不明です！中止します！": Exit Sub
    End If
    For i = 3 To lnRow
        OpenFileName = PathName & Cells(i, 1).Value
        strNewFileName = PathName & Cells(i, 2).Value
        If Dir(strNewFileName) <> "" Then
            MsgBox strNewFileName & "はすでに存在します"
            Cells(i, 3).Value = "失敗"
        Else
            Name OpenFileName As strNewFileName
            Cells(i, 3).Value = "成功"
        End If
    Next
    MsgBox "設定したファイル名の変更が終了しました", _
                vbOKOnly + vbInformation, "ファイル名一括変更"
End Sub
Sub selectionFolder()
    Dim strWORK As String
    strWORK = getFOLDER()  'フォルダーの選択関数を呼ぶ
    Range("B1").Formula = strWORK
End Sub

'フォルダー選択ダイアログを表示
Function getFOLDER() As String
    Dim dlg As FileDialog

    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    ' キャンセルボタンクリック時
    If dlg.Show = False Then
        getFOLDER = ""
        Exit Function
    End If
    ' フォルダーのフルパスを変数に格納
    getFOLDER = dlg.SelectedItems(1)
    Set dlg = Nothing
End Function

'フォルダ内のファイル名を取出して、セルに反映する
Sub GetFileNameSet()
    Dim strFolder   As String  'フォルダー名
    Dim strFileName As String  'ファイル名
    Dim nYLine      As Integer '行カウンタ
    Dim strFileType As String
    
    strFileType = Range("G4")  'ファイル形式
    Call selectionFolder
    strFolder = Range("B1") & "\"  '検索するフォルダー
    strFileName = Dir(strFolder & strFileType) '最初のファイル名
    'ファイルが見つからなくなるまでループしてデータをセットする
    nYLine = 3  '3行目からセット
    'セルデータ初期化
    Range(Cells(nYLine, 1), Cells(nYLine, 3).End(xlDown)) = ""
    Do While strFileName <> ""   ' ループを開始します。
        'セルにファイル名をセットする
        If strFileName <> "" Then
            Cells(nYLine, 1) = strFileName 'セルにファイル名をセット
            nYLine = nYLine + 1      'カウントアップ
        End If
        strFileName = Dir   '次のファイル名を返す
    Loop

End Sub