【コピペでOK】VBAで全てのファイルを一括で文字列置換するツールを作成

ツール作成(VBA)
2022.03.28

VBAでファイルの一覧を取得して一括ですべてのファイルの指定した文字列を置換するツールのご紹介です。

仕事現場でクライアントの急な方針転換により大量の修正(主に言葉の言い回しや固有名詞など)が発生したために作成しました。

置換以外にも客先提出のファイルの為おまけの機能が付いています

メイン機能

  • サブフォルダを含めてファイル一覧を取得
  • 複数の指定した文字列をすべてのファイルとシートを対象に置換する

おまけ機能

  • 全てのシートを一番最初のシートに切り替える
  • すべてのシートの倍率を100%にする
  • A1セルの選択
  • 文字を黒字にする

コピペで使用できるコード全文

Excelシート側のツール完成例

コードは以下の3つのモジュールからなります。標準モジュールをそれぞれ３つに分けてコピペしてください

createFileList
以前にも別の記事で紹介しましたサブフォルダを含めてすべてのファイルを一括で取得する事前処理のモジュールです。3つのプロシージャで構成されていてmain()をメインのプロシージャとして、その記述の中でbeforeProcess()、mainProcess()の二つのプロシージャをそれぞれ呼び出しています。

  • main() ⇒　　ボタンに設定するメインのプロシージャ
  • beforeProcess() ⇒　前処理を行うプロシージャ
  • mainProcess() ⇒　ファイル一覧の取得処理をするプロシージャ

設置するボタン・・・ 『ファイルの一覧を取得する』ボタン

Option Explicit
Dim startRow As Integer
Dim folderPass As String
Dim ext As String

'ファイル名を取得(サブフォルダを含む)
Sub main()

'処理対象のファイルを開いた際のメッセージをオフにする
Application.DisplayAlerts = False

'処理実行時の画面描画をオフにして処理を高速化
Application.ScreenUpdating = False

'前処理
Call beforeProcess

'ファイル名取得のメイン処理を行うプロシージャを呼び出す
Call mainProcess(folderPass, startRow)

End Sub
Sub beforeProcess()

'ファイル名一覧を出力する行番号を指定します。
startRow = 7

'対象フォルダのパスがあるセルを指定し、値を代入します。
folderPass = Range("C5").Value

'拡張子の選択
ext = Range("E5").Value
    
'指定範囲の値をクリア
Range("B7:C10000").ClearContents
Range("B7:E10000").Interior.ColorIndex = 0

End Sub

'ファイル名を取得(サブフォルダを含む)のメイン処理を行う
Sub mainProcess(folderPass As String, startRow As Integer)

Dim fso As Object
Dim filePath As Object
Dim subFilePath As Object

'対象フォルダのパスの値があれば処理
If folderPass = "" Then
    MsgBox "C5セルにフォルダパスを記入してください"
    Exit Sub
Else

    'ファイルやフォルダを操作するオブジェクトFileSystemObjectを変数にセット
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'ファイル情報を出力
For Each filePath In fso.GetFolder(folderPass).Files

'拡張子を判定
If (LCase(fso.GetExtensionName(filePath)) = LCase(ext)) Then
'ファイル名・ファイルパスの出力
        Cells(startRow, 2) = filePath.Name
        Cells(startRow, 3) = filePath.Path
        startRow = startRow + 1
ElseIf LCase(ext) = "" Then
        Cells(startRow, 2) = filePath.Name
        Cells(startRow, 3) = filePath.Path
        startRow = startRow + 1
End If
    Next filePath

    'サブフォルダ内のファイル名取得の処理
    For Each subFilePath In fso.GetFolder(folderPass).SubFolders
    
        If subFilePath.Name <> "" Then
            'サブフォルダのパスをmainProcessに渡して再帰的に処理
            Call mainProcess(subFilePath.Path, startRow)
    
       End If
    Next subFilePath

End If

Set fso = Nothing
Set filePath = Nothing
Set subFilePath = Nothing

End Sub

fileReplace
文字列置換をするメイン処理のモジュールになります。2つのプロシージャで構成されていてfileReplaceMain()をメインのプロシージャとして、その記述の中でmodification()を呼び出しています。

  • fileReplaceMain() ⇒　　処理を実行するメインのプロシージャ
  • modification()　　⇒　　fileReplaceMain()に呼び出されるプロシージャ

設置するボタン・・・ 『文字列を置換する』ボタン

Option Explicit
Private wb, wb2 As Workbook
Private ws2 As Worksheet
Sub fileReplaceMain()
    Dim fileFullPath As String
    Dim startRow As Long

'処理対象のファイルを開いた際のメッセージをオフにする
Application.DisplayAlerts = False

'処理実行時の画面描画をオフにして処理を高速化
Application.ScreenUpdating = False
 
 Set ws2 = ActiveWorkbook.Worksheets("sheet1")
 
Range("B7").Select
Range("B7:E10000").Interior.ColorIndex = 0

For startRow = 7 To Cells(Rows.Count, 2).End(xlUp).Row
    'ファイルのパスを指定
    fileFullPath = Cells(startRow, 3).Value
    'パスに格納されているファイルを開く
   Set wb = Workbooks.Open(fileFullPath)
   
    Call modification(wb, ws2)
    
    'ファイルを保存して閉じる
    wb.Close savechanges:=True
  On Error GoTo myError
Next

   MsgBox "処理が完了しました"
  Exit Sub
myError:
  Cells(startRow, 2).Interior.ColorIndex = 6
  Cells(startRow, 3).Interior.ColorIndex = 6
  Cells(startRow, 4).Interior.ColorIndex = 6
  MsgBox "エラー" & vbCrLf & Err.Description
  Resume Next
End Sub
Sub modification(wb, ws2)
Dim Ws As Worksheet
Dim startRow As Long
Dim beforeReplace, afterReplace As String

    For Each Ws In Worksheets
    Ws.Activate
    
    '痴漢以外の処理が必要な場合はココに記述する
      
          For startRow = 7 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
            '変更前の文字列
            beforeReplace = ws2.Cells(startRow, 4).Value
            '変更後の文字列
            afterReplace = ws2.Cells(startRow, 5).Value
            With Application.ReplaceFormat
                .Clear
                .Font.Color = RGB(255, 0, 0)
            End With
            '指定した文字列を痴漢する
            Cells.Replace What:=beforeReplace, Replacement:=afterReplace, LookAt:=xlPart, ReplaceFormat:=True

        Next
    Next Ws
End Sub

afterProcess
今回のおまけ機能で紹介した最終的な体裁を整えるモジュールです。処理は下記2つのプロシージャに分割されており、ボタンに設定するのはメインのプロシージャでafterProcessMain()になります。

  • afterProcessMain() ⇒　　処理を実行するメインのプロシージャ
  • fileModification()　　⇒　　afterProcessMain()に呼び出されるプロシージャ

設置するボタン・・・ 『体裁修正』ボタン

Option Explicit
Private wb, wb2 As Workbook
Private ws2 As Worksheet
Sub afterProcessMain()
    Dim fileFullPath As String
    Dim startRow As Long

'処理対象のファイルを開いた際のメッセージをオフにする
Application.DisplayAlerts = False

'処理実行時の画面描画をオフにして処理を高速化
Application.ScreenUpdating = False
 
 Set ws2 = ActiveWorkbook.Worksheets("sheet1")
 
Range("B7").Select
Range("B7:E10000").Interior.ColorIndex = 0

For startRow = 7 To Cells(Rows.Count, 2).End(xlUp).Row
    'ファイルのパスを指定
    fileFullPath = Cells(startRow, 3).Value
    'パスに格納されているファイルを開く
   Set wb = Workbooks.Open(fileFullPath)
   
    Call fileModification(wb, ws2)
    
    'ファイルを保存して閉じる
    wb.Close savechanges:=True

Next

   MsgBox "処理が完了しました"
  Exit Sub
End Sub

Sub fileModification(wb, ws2)
Dim Ws As Worksheet
Dim startRow As Long
Dim beforeReplace, afterReplace As String

    For Each Ws In Worksheets
    Ws.Activate
    
    '最終的なファイルの体裁修正の処理
      Cells.Font.Color = RGB(0, 0, 0)
      ActiveWindow.Zoom = 100
      Range("A1").Select
      
    Next Ws
    Sheets(1).Select
End Sub

タイトルとURLをコピーしました