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

'--------------------------------------------------------------------------------
'【実行用マクロ】　指定フォルダ・配下フォルダの全ブックで任意の文字列を一括置換
'--------------------------------------------------------------------------------
' https://excel.syogyoumujou.com/vba/replace_books_in_subordinatefolders.html
'--------------------------------------------------------------------------------
Sub replaceBooksInAllSubordinateFolders()

    '---------------------------------------------
    ' 検索文字列・置換後文字列
    '---------------------------------------------
    Dim varArray1dWhat As Variant
    Dim varArray1dRepl As Variant
    
    '要素毎に対【例】神田川→神奈川、チーバ→千葉、君→県
    varArray1dWhat = Array("神田川", "チーバ", "君")  '検索する文字列
    varArray1dRepl = Array("神奈川", "千葉", "県")    '置き換える文字列
    
    '---------------------------------------------
    ' 指定フォルダ・配下の全サブフォルダパス取得
    '---------------------------------------------
    Dim colFolderPath As New Collection
    '《指定フォルダ・配下フォルダのパス取得》
    ' ** 引数1：基準とするフォルダパス
    ' ** 引数2：フォルダパスを追加するコレクション
    '   戻り値： 0：成功
    '           -1：フォルダ選択ダイアログボックスで「キャンセル」を選択
    If getSubordinateFolders("", colFolderPath) = -1 Then GoTo LBL_FINALLY

    '---------------------------------------------
    ' 各フォルダのExcelブックパスを取得
    '---------------------------------------------
    Dim varFolderPath As Variant
    Dim strTarget     As String
    Dim colFilePath   As New Collection
    
    For Each varFolderPath In colFolderPath
        ' フォルダパスにフォルダ区切り文字追加
        varFolderPath = varFolderPath & Application.PathSeparator
        
        ' フォルダ内のExcelファイルを検索
        strTarget = Dir(varFolderPath & "*.xls?")

        Do Until strTarget = "" ' ファイルがなければ抜ける
            ' ファイルパスをコレクションに追加
            colFilePath.Add varFolderPath & strTarget, CStr(colFilePath.Count + 1)
            
            ' 次のファイル検索
            strTarget = Dir()
        Loop
    Next
    
    ' ファイルパス数が 0 の場合は終了
    If colFilePath.Count = 0 Then
        MsgBox "Excelファイルは見つかりませんでした", vbInformation
        GoTo LBL_FINALLY
    End If

    '---------------------------------------------
    ' 処理実行確認
    '---------------------------------------------
    If MsgBox("対象となるExcelブック：" & colFilePath.Count & vbLf & _
              "置換を実行しますか？" & vbLf & _
              "※ブック数やサイズによっては時間を要します", _
              vbQuestion + vbYesNo) = vbNo Then
        GoTo LBL_FINALLY
    End If
    
    '---------------------------------------------
    ' 置換実行
    '---------------------------------------------
On Error Resume Next

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim wbkTarget   As Workbook
    Dim shtTarget   As Worksheet
    Dim varFilePath As Variant
    Dim i           As Long
    For Each varFilePath In colFilePath
        ' ファイルのパスがマクロ実行ブックと同じ場合は置換対象外
        If varFilePath <> ThisWorkbook.FullName Then
            Set wbkTarget = Workbooks.Open(varFilePath)
            
            If Not wbkTarget Is Nothing Then
                For Each shtTarget In wbkTarget.Worksheets
                    ' シートの保護確認
                    If Not shtTarget.ProtectContents Then
                        ' シートが保護されていない場合に置換を実行
                        For i = 0 To UBound(varArray1dWhat)
                            '《対象セル範囲の任意の文字列を置換》
                            Call replaceTargetCell(shtTarget.Cells, varArray1dWhat(i), varArray1dRepl(i))
                        Next
                    End If
                Next
                
                'ブックが変更されていたら保存する
                If wbkTarget.Saved = False Then wbkTarget.Save
                wbkTarget.Close
            End If
        End If
    Next
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
On Error GoTo 0
    
    MsgBox "置換処理を終了しました", vbInformation

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

'--------------------------------------------------------------------------------
' 指定フォルダ・配下フォルダのパス取得（再帰関数）
'--------------------------------------------------------------------------------
'［引数］
'   FolderPath   ：対象フォルダパス
'   colFolderPath：フォルダパスを追加するコレクションオブジェクト
'［戻り値］
'    0：成功
'   -1：フォルダ選択ダイアログボックスで「キャンセル」をクリック
'［作成日］2023.07.07　［更新日］2025.11.22
' 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)
            Else
                ' 「キャンセル」をクリックした場合は終了
                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 Exit Function
    
    ' コレクションにフォルダパスを追加
    colFolderPath.Add FolderPath, CStr(colFolderPath.Count + 1)
    
    ' フォルダパスにフォルダ区切文字を追加
    FolderPath = FolderPath & Application.PathSeparator
    
On Error Resume Next

    Dim F As Object
    If 0 < fso.GetFolder(FolderPath).SubFolders.Count Then
    
        ' サブフォルダが存在する場合 配下のサブフォルダに移る
        For Each F In fso.GetFolder(FolderPath).SubFolders
            ' アクセス制限フォルダの場合は抜ける
            If F Is Nothing Then Exit Function
            '《再帰》
            If getSubordinateFolders(FolderPath & F.Name, colFolderPath) = -1 Then
                getSubordinateFolders = -1
                Exit For
            End If
        Next
    End If
    
On Error GoTo 0
End Function

'-------------------------------------------------------------------------------------
' 対象セル範囲の任意の文字列を置換
'-------------------------------------------------------------------------------------
'［引数］
'   rngTarget      ：対象セル範囲
'   What           ：検索する文字列
'   Replacement    ：置き換える文字列
'   LookAt         ：一致の種類    部分一致：xlPart[既定]　全体一致：xlWhole
'   SearchOrder    ：検索方法   1行ごと検索：xlByRows[既定]　1列ごと検索：xlByColumns
'   SearchDirection：検索順  一致する次の値：xlNext[既定]　一致する前の値：xlPrevious
'   MatchCase      ：大文字・小文字の区別  区別する：True　区別しない：False[既定]
'   MatchByte      ：全角・半角の区別      区別する：True　区別しない：False[既定]
'［作成日］2023.12.20　［更新日］2025.11.22
' https://excel.syogyoumujou.com/vba/cells_replace_allbooks.html
'-------------------------------------------------------------------------------------
Sub replaceTargetCell(ByRef rngTarget As Range, _
                      ByVal What As String, _
                      ByVal Replacement As String, _
             Optional ByVal LookAt As XlLookAt = xlPart, _
             Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
             Optional ByVal MatchCase As Boolean = False, _
             Optional ByVal MatchByte As Boolean = False)
    Call rngTarget.Replace(What, Replacement, LookAt, SearchOrder, MatchCase, MatchByte)
End Sub