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

'----------------------------------------------------------------------
' 【実行マクロ】指定フォルダ内の全ブックで任意の文字列を一括置換
'----------------------------------------------------------------------
' https://excel.syogyoumujou.com/vba/cells_replace_allbooks.html
'----------------------------------------------------------------------
Sub replaceAllBooksForAnyString() 'メイン
    '----------------------------------------
    ' 検索文字列・置換後文字列
    '----------------------------------------
    Dim varArray1dWhat As Variant
    Dim varArray1dRepl As Variant
    
    '要素毎に対【例】神田川→神奈川、チーバ→千葉、君→県
    varArray1dWhat = Array("神田川", "チーバ", "君")  '検索する文字列
    varArray1dRepl = Array("神奈川", "千葉", "県")    '置き換える文字列

    '--------------------------------
    ' フォルダの選択
    '--------------------------------
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then strFolderPath = .SelectedItems(1)
    End With
    If Len(strFolderPath) = 0 Then Exit Sub

    '--------------------------------
    ' フォルダの存在確認
    '--------------------------------
    If Dir(strFolderPath, vbDirectory) = "" Then
        MsgBox "対象のフォルダが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If

    '--------------------------------
    ' フォルダ内ブックを検索
    '--------------------------------
    Dim strFileName As String
    strFolderPath = strFolderPath & Application.PathSeparator 'フォルダパスに区切り文字追加
    strFileName = Dir(strFolderPath & "*.xls?")               'フォルダからExcelブックを検索
    If strFileName = "" Then                                  'ブックのパスを取得できなければ終了
        MsgBox "指定フォルダ内にExcelブックが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False                        '画面更新無効
    Application.EnableEvents = False                          'イベント無効

    '--------------------------------
    ' ブック内から文字列を検索
    '--------------------------------
    Dim bokTarget As Workbook
    Dim shtTarget As Worksheet
    Dim i         As Long
    On Error Resume Next
    Do
        'フォルダ内のブックを開く
        Set bokTarget = Workbooks.Open(strFolderPath & strFileName)
        
        '------------------------------------------------------
        ' 各シートで置換を実行　※保護されているシートは対象外
        '------------------------------------------------------
        For Each shtTarget In bokTarget.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 bokTarget.Saved = False Then bokTarget.Save
        'ブックを閉じる
        bokTarget.Close
        
        strFileName = Dir()     '次のExcelブックを検索
    Loop Until strFileName = "" 'ブックが見つからなければループから抜ける
    On Error GoTo 0
    
    strFileName = Dir("")
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "処理を終了しました", vbInformation
End Sub

'-------------------------------------------------------------------------------------
' 対象セル範囲から任意の文字列を置換するプロシージャ
'-------------------------------------------------------------------------------------
'［引数］
'   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

'-------------------------------------------------------------------------
' フォルダ内の全てのブックを対象に置換を実行
'-------------------------------------------------------------------------
' 検索と置換の文字列をセル範囲に記載するバージョン
' 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:=xlByRows, _
                                 MatchCase:=False, _
                                 MatchByte:False
            End If
        Next
    Next
    If WB.Saved = False Then WB.Save  'ブックの内容が変更されていたらセーブ
    WB.Close                          'ブックを閉じる
End Sub