トップ　>　汎用コード　>　複数の単語を一括置換（指定フォルダの全ブック対象）

'+++ 宣言セクション +++
Dim varSearch As Variant
Dim varAfRepl As Variant

Sub All_Books_Replace() '実行用マクロ　フォルダ内全てのブックを対象に検索と置換実行

    '要素毎に対　【例】神田川→神奈川、チーバ→千葉、君→さん
    varSearch = Array("神田川", "チーバ", "君")  '検索文字列
    varAfRepl = Array("神奈川", "千葉", "さん")  '置換文字列
    
    Dim strDirPath As String
    
    'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then strDirPath = .SelectedItems(1)
    End With
    If Len(strDirPath) = 0 Then Exit Sub
    
    'フォルダの存在確認
    If Dir(strDirPath, vbDirectory) = "" Then Exit Sub
    
    'フォルダ内ブック検索・置換処理
    Call Search_Books(strDirPath)
    
End Sub

Private Sub Search_Books(ByVal strPath As String) 'フォルダ内ブック検索
    Dim strTarget  As String
    Dim strDirPath As String
    With Application
        strPath = strPath & .PathSeparator  'フォルダパスにフォルダ区切り文字追加
        strTarget = Dir(strPath & "*.xls?") 'フォルダ内のExcelブックを検索
        If strTarget = "" Then Exit Sub     'ブックがなければ終了
        .ScreenUpdating = False             '画面更新停止
        .DisplayAlerts = False              '確認メッセージ非表示
        On Error Resume Next
            Do
                Call Books_Replace_Main(.Workbooks.Open(strPath & strTarget)) 'ブックを開き置換処理
                strTarget = Dir()           '次のExcelブックを検索
            Loop Until strTarget = ""       'ブックがなければループから抜ける
        On Error GoTo 0
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    strTarget = Dir("")
End Sub

Private Sub Books_Replace_Main(WB As Workbook) 'ブック内全シートの置換処理
    Dim Sh As Worksheet
    Dim i  As Long
    With WB
        For Each Sh In .Worksheets
            For i = LBound(varSearch) To UBound(varSearch)
                Sh.Cells.Replace What:=varSearch(i), _
                                 Replacement:=varAfRepl(i), _
                                 LookAt:=xlPart, _
                                 SearchOrder:=xlByColumns, _
                                 MatchCase:=False, _
                                 MatchByte:=False
            Next
        Next
        If .Saved = False Then .Save    'ブックの内容が変更されていたらセーブ
        .Close                          'ブックを閉じる
    End With
End Sub

'-------------------------------------------------------------------------
' フォルダ内の全てのブックを対象に置換を実行
'-------------------------------------------------------------------------
' 検索と置換の文字列をセル範囲に記載するバージョン
' https://excel.syogyoumujou.com/vba/cells_replace_allbooks.html
'-------------------------------------------------------------------------

'宣言セクション
Private varSearchTarget      As Variant '検索文字列格納用
Private varReplacementTarget As Variant '置換文字列格納用

'-------------------------------------------------------------------------
' メインマクロ
'-------------------------------------------------------------------------
Sub ReplaceAllBooks2()

    '検索文字列と置換文字列を変数に格納
    varSearchTarget = ActiveSheet.Range("A2:A5").Value
    varReplacementTarget = ActiveSheet.Range("B2:B5").Value
    
    '配列チェック1（単一のセルの場合は対象外）
    Dim bolCheck As Boolean
    If Not IsArray(varSearchTarget) Then bolCheck = True
    If Not IsArray(varReplacementTarget) Then bolCheck = True
    If bolCheck Then
        MsgBox "セル範囲を指定してください", vbInformation
        Exit Sub
    End If

    '配列チェック2（セル範囲の大きさを確認）
    If UBound(varSearchTarget) <> UBound(varReplacementTarget) Then
        MsgBox "検索と置換に指定したセルの大きさが異なります", vbInformation
        Exit Sub
    End If
    
    'フォルダ内の全ファイルパス取得
    Dim colFilePath As New Collection
    If GetAllFilePaths("", colFilePath) = -1 Then
        'フォルダ選択で「キャンセル」を選択の場合は終了
        Exit Sub
    End If
    
    'ファイルがなければ終了
    If colFilePath.Count = 0 Then
        MsgBox "指定のフォルダにファイルは見つかりませんでした", vbInformation
        Exit Sub
    End If
    
    'Excelファイルの場合はブックを開き置換処理を実行
    Dim i As Long
    Application.ScreenUpdating = False
    With CreateObject("Scripting.FileSystemObject")
        For i = 1 To colFilePath.Count
            'マクロ実行ブックは対象外
            If colFilePath(i) <> ThisWorkbook.FullName Then
                Select Case .GetExtensionName(colFilePath(i)) '拡張子を確認
                Case "xls", "xlsx"
                    If ThisWorkbook.Path <> colFilePath(i) Then
                        Call ReplaceAllWorksheets(Workbooks.Open(colFilePath(i)))
                    End If
                Case Else
                End Select
            End If
        Next
    End With
    Application.ScreenUpdating = True
    
    MsgBox "処理終了", vbInformation
End Sub

'--------------------------------------------------------------------------------
' 指定フォルダ内の全ファイルパスを取得
'--------------------------------------------------------------------------------
'［引数］
'   FolderPath ：対象フォルダパス
'   colFilePath：ファイルパスを格納するためのコレクションオブジェクトを指定
'［戻り値］
'    0：成功
'   -1：フォルダ選択ダイアログボックスで「キャンセル」をクリック
'［作成日］
'   2023/07/14
' https://excel.syogyoumujou.com/vba/cells_replace_allbooks.html#r_code1
'--------------------------------------------------------------------------------
Function GetAllFilePaths(ByVal FolderPath As String, _
                         ByRef colFilePath As Collection) As Long

    'フォルダパスが空の場合にはファイル選択ダイアログボックスを表示
    If FolderPath = "" Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "フォルダを選択してください"
            If .Show = True Then FolderPath = .SelectedItems(1)
            
            '「キャンセル」をクリックした場合は終了
            If FolderPath = "" Then
                GetAllFilePaths = -1
                Exit Function
            End If
        End With
    End If

    'ファイルシステムオブジェクトの生成
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'フォルダの存在確認　存在しない場合は抜ける
    If Not FSO.FolderExists(FolderPath) Then GoTo FINALLY
    
    '対象フォルダを設定
    Dim objDir As Object
    Set objDir = FSO.GetFolder(FolderPath)
        
    On Error Resume Next
    With objDir
        Dim F As Object
        'ファイル数をカウント
        If 0 < .Files.Count Then
            'コレクションオブジェクトにファイルパスを追加
            For Each F In .Files
                colFilePath.Add F.Path
            Next
        End If
    End With
    On Error GoTo 0

FINALLY:
    Set objDir = Nothing
    Set FSO = Nothing
    
End Function

'-------------------------------------------------------------------------
' 対象ブック内全シートの置換処理
'-------------------------------------------------------------------------
'［引数］
'   WB：対象ブック
'-------------------------------------------------------------------------
Private Sub ReplaceAllWorksheets(WB As Workbook)
    Dim Sh As Worksheet
    Dim i  As Long
    For Each Sh In WB.Worksheets
        For i = LBound(varSearchTarget) To UBound(varSearchTarget)
            If Not IsEmpty(varSearchTarget(i, 1)) Then
                Sh.Cells.Replace What:=varSearchTarget(i, 1), _
                                 Replacement:=varReplacementTarget(i, 1), _
                                 LookAt:=xlPart, _
                                 SearchOrder:=xlByColumns, _
                                 MatchCase:=False, _
                                 MatchByte:=False
            End If
        Next
    Next
    If WB.Saved = False Then WB.Save  'ブックの内容が変更されていたらセーブ
    WB.Close                          'ブックを閉じる
End Sub