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

'+++ 宣言セクション +++
Private Pr_varSearch  As Variant
Private Pr_varReplace As Variant

'--------------------------------------------------------------------------------
' 実行用マクロ　指定したフォルダとその全ての配下フォルダ内のExcelブックを一括置換
' https://excel.syogyoumujou.com/vba/replace_books_in_subordinatefolders.html
'--------------------------------------------------------------------------------
Sub ReplaceBooksInAllSubordinateFolders()

    '検索文字列と置換文字列の設定
    ' 要素毎に対　【例】神田川→神奈川、チーバ→千葉、君→さん
    Pr_varSearch = Array("神田川", "チーバ", "君")   '検索文字列
    Pr_varReplace = Array("神奈川", "千葉", "さん")  '置換文字列

    'フォルダパス格納用のコレクションオブジェクトを生成
    Dim colFolderPath As New Collection
    
    '指定したフォルダとその配下の全サブフォルダのパスを取得
    If GetSubordinateFolders("", colFolderPath) = -1 Then
        'フォルダ選択ダイアログボックスで「キャンセル」の場合は終了
        GoTo FINALLY
    End If
    
    'Excelブックパス格納用のコレクションオブジェクトを生成
    Dim colFilePath As New Collection
    
    Dim i           As Long
    Dim j           As Long
    Dim varFilePath As Variant
    For i = 1 To colFolderPath.Count
        '指定したフォルダ内のExcelブックパスを取得
        varFilePath = GetArray1dSpecifiedFilesPath(colFolderPath.Item(i), "xls?")
        
        'varFilePathが配列の場合はExcelブックパスの取得成功
        If IsArray(varFilePath) Then
            For j = 0 To UBound(varFilePath)
                'コレクションオブジェクトにファイルパスを追加
                colFilePath.Add varFilePath(j)
            Next
        End If
    Next
    
    'ファイルパスが0の場合は終了
    If colFilePath.Count = 0 Then
        MsgBox "Excelファイルは見つかりませんでした", vbInformation
        GoTo FINALLY
    End If
    
    If MsgBox("対象となるExcelブック：" & colFilePath.Count & vbLf & _
              "置換を実行しますか？" & vbLf & _
              "※ブック数やサイズによっては時間を要します", _
              vbQuestion + vbYesNo) = vbNo Then
        GoTo FINALLY
    End If
    
    '画面更新を停止する場合は次の行のコメントを外す
    'Application.ScreenUpdating = False
    
    On Error Resume Next
    
    '取得したファイルパスを基に置換実行
    For i = 1 To colFilePath.Count
        'ファイルのパスがマクロ実行ブックと同じ場合は置換ブック対象外
        If colFilePath.Item(i) <> ThisWorkbook.FullName Then
            Call ReplaceAllWorksheets(Workbooks.Open(colFilePath.Item(i)))
        End If
    Next

    On Error GoTo 0

    'Application.ScreenUpdating = True
    
    MsgBox "置換処理を終了しました", vbInformation

FINALLY:
    Set colFilePath = Nothing
    Set colFolderPath = Nothing
End Sub

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

    'フォルダパスが空の場合にはフォルダ選択ダイアログボックスを表示
    If FolderPath = "" Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "フォルダを選択してください"
            If .Show = True Then FolderPath = .SelectedItems(1)
            
            '「キャンセル」をクリックした場合は終了
            If FolderPath = "" Then
                GetSubordinateFolders = -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
    
    'コレクションオブジェクトにフォルダパスを追加
    colFolderPath.Add FolderPath
    
    '対象フォルダを設定
    Dim objDir As Object
    Set objDir = FSO.GetFolder(FolderPath)
    
    'フォルダパスにフォルダ区切文字を追加
    FolderPath = FolderPath & Application.PathSeparator
    
    On Error Resume Next
    With objDir
        Dim F As Object
        'サブフォルダ数をカウント
        If 0 < .SubFolders.Count Then
            'サブフォルダ数が1以上の場合サブフォルダに移る
            For Each F In .SubFolders
                '再帰
                If GetSubordinateFolders(FolderPath & F.Name, colFolderPath) = -1 Then
                    GoTo FINALLY
                End If
            Next
        End If
    End With
    On Error GoTo 0

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

'--------------------------------------------------------------------------------
' 指定フォルダ内の任意の拡張子のファイルパスを1次元配列として取得する関数
'--------------------------------------------------------------------------------
'［引数］
'   FolderPath：検索対象のフォルダパスを指定
'   Extension ：拡張子を文字列で指定　ワイルドカード使用可
'               【指定例1】"docx"　【指定例2】"xls?"
'［戻り値］
'   ファイルパスが格納された1次元配列
'   指定した拡張子のファイルが見つからなかった場合は Empty
'［作成日］
'   2023/07/07
' https://excel.syogyoumujou.com/vba/replace_books_in_subordinatefolders.html
'--------------------------------------------------------------------------------
Function GetArray1dSpecifiedFilesPath(ByVal FolderPath As String, _
                                      ByVal Extension As String) As Variant
    '指定のフォルダが存在しない場合は抜ける
    If Dir(FolderPath, vbDirectory) = "" Then Exit Function
                                      
    'フォルダパスにフォルダ区切り文字追加
    FolderPath = FolderPath & Application.PathSeparator
    
    'フォルダ内で対象拡張子のファイルを検索
    Dim strTarget  As String
    strTarget = Dir(FolderPath & "*." & Extension)
    
    'ファイルがなければ終了
    If strTarget = "" Then Exit Function
    
    Dim varArray1d() As Variant
    Dim lngCount     As Long
    
    Do
        'ファイルパスを配列に格納
        ReDim Preserve varArray1d(lngCount)
        varArray1d(lngCount) = FolderPath & strTarget
        lngCount = lngCount + 1
        strTarget = Dir()           '次のファイルを検索
    Loop Until strTarget = ""       'ファイルがなければループから抜ける
    
    strTarget = Dir("")
    
    GetArray1dSpecifiedFilesPath = varArray1d
End Function

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