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

'--------------------------------------------------------------------------------
'【実行用マクロ】　指定フォルダ・配下フォルダの全ブックで任意の文字列を一括置換
'--------------------------------------------------------------------------------
' 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
    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ファイルパスを取得
        '※該当ファイルが存在する場合、ファイルパスが格納された1次元配列が返る
        varFilePath = getArray1dSpecifiedFilesPath(colFolderPath.Item(i), "xls?")
        
        'varFilePathが配列の場合はコレクションオブジェクトにファイルパスを追加
        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
    
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    '---------------------------------------------------------
    ' 取得したファイルパスのブックを開き全シートで置換実行
    '---------------------------------------------------------
    Dim bokTarget As Workbook
    Dim shtTarget As Worksheet
    For i = 1 To colFilePath.Count
        'ファイルのパスがマクロ実行ブックと同じ場合は置換対象外
        If colFilePath.Item(i) <> ThisWorkbook.FullName Then
            Set bokTarget = Workbooks.Open(colFilePath.Item(i))
            For Each shtTarget In bokTarget.Worksheets
                For j = 0 To UBound(varArray1dWhat)
                    Call replaceTargetCell(shtTarget.Cells, varArray1dWhat(j), varArray1dRepl(j))
                Next
            Next
            'ブックが変更されていたら保存する
            If bokTarget.Saved = False Then bokTarget.Save
            bokTarget.Close
        End If
    Next
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    On Error GoTo 0
    
    MsgBox "置換処理を終了しました", vbInformation

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

'--------------------------------------------------------------------------------
' 指定フォルダとその全ての配下フォルダのパスを取得（再帰関数）
'--------------------------------------------------------------------------------
'［引数］
'   FolderPath   ：対象フォルダパス
'   colFolderPath：フォルダパスを格納するためのコレクションオブジェクトを指定
'［戻り値］
'    0：成功
'   -1：フォルダ選択ダイアログボックスで「キャンセル」をクリック
'［作成日］2023.07.07　［更新日］2023.12.21
' 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
    
    'フォルダパスにフォルダ区切文字を追加
    FolderPath = FolderPath & Application.PathSeparator
    
    On Error Resume Next
    Dim F As Object
    If 0 < fso.GetFolder(FolderPath).SubFolders.Count Then
        'サブフォルダ数が1以上の存在する場合配下のサブフォルダに移る
        For Each F In fso.GetFolder(FolderPath).SubFolders
            '再帰
            If getSubordinateFolders(FolderPath & F.Name, colFolderPath) = -1 Then
                getSubordinateFolders = -1
                Exit Function
            End If
        Next
    End If
    On Error GoTo 0
End Function

'--------------------------------------------------------------------------------
' 指定フォルダ内の任意の拡張子のファイルパスを1次元配列として取得する関数
'--------------------------------------------------------------------------------
'［引数］
'   FolderPath：検索対象のフォルダパスを指定
'   Extension ：拡張子を文字列で指定　ワイルドカード使用可
'               【指定例1】"docx"　【指定例2】"xls?"
'［戻り値］
'   ファイルパスが格納された1次元配列
'   指定した拡張子のファイルが見つからなかった場合は Empty
'［作成日］2023.07.07　［更新日］2023.12.21
' 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

'-------------------------------------------------------------------------------------
' 対象セル範囲から任意の文字列を置換するプロシージャ
'-------------------------------------------------------------------------------------
'［引数］
'   rngTarget      ：対象セル範囲
'   What           ：検索する文字列
'   Replacement    ：置き換える文字列
'   LookAt         ：一致の種類    部分一致：xlPart[既定]　全体一致：xlWhole
'   SearchOrder    ：検索方法   1行ごと検索：xlByRows[既定]　1列ごと検索：xlByColumns
'   SearchDirection：検索順  一致する次の値：xlNext[既定]　一致する前の値：xlPrevious
'   MatchCase      ：大文字・小文字の区別  区別する：True　区別しない：False[既定]
'   MatchByte      ：全角・半角の区別      区別する：True　区別しない：False[既定]
'［作成日］2023.12.20　［更新日］2023.12.21
' 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