複数の単語を一括置換(指定フォルダ・配下フォルダ内全ブック対象)2023.07.07
指定したフォルダと、その配下の全てのフォルダ内の全ブック・全シートを対象に、複数の文字列を一括で置換するマクロです。
[1つのフォルダ内のみ全ブックを対象に一括置換]はこちら
マクロを実行すると、フォルダ選択ダイアログが表示されます。
フォルダを選択すると、そのフォルダと配下フォルダのExcelブックが検索され、見つかったブックの全シートに置換処理が実行されます。
マクロ実行後に「元に戻す」機能は使用できません。
【お薦め】マクロ・プロシージャを管理する無料のツール!
Excelマクロ管理ツール
Excelマクロ管理ツール
サンプルコード
'+++ 宣言セクション +++ 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
「検索文字列」
シート内から検索する文字列です。
「置換文字列」
検索した文字列を置き換える文字列です。
検索文字列と置換文字列は要素が対になっています。
要素が対であれば、要素の増減が可能です。
●サンプルファイル ダウンロード