VBAでGrep置換を実装した(フォルダ内のファイルの文字列を全て置換)

VBAでGrep置換を実装するメリット

フォルダの中にある全てファイルに対して、文字列の置換をしたい場合、一つずつファイルを開いて対応するのは面倒ですよね。

自分はそんな時にサクラエディタのGrep置換機能を使用していたのですが、最近は自前のExcelVBAで対応するようにしています。

ExcelVBAを使うメリットとしては、置き換える文字列をワークシート上に定義しておけることですね。

サクラエディタの機能で置き換える場合は、複数ワードを置換した場合は何度も対応しないといけないのが面倒だったです。(こちらもマクロ作ればいけるのかもですが)

今回の記事では以下のVBAについて紹介します。

  • フォルダ内のテキストファイルの文字列をGrep置換する
  • フォルダ内のファイル名をGrep置換する
  • フォルダ内のExcelファイルの文字列をGrep置換する

今回の記事用に作ったものをアップロードしているので、すぐに使いたい方は以下をダウンロードすれば試せます。

フォルダ内のテキストファイルの文字列をGrep置換する

https://vbaexcel.slavesystems.com/product/text_grep_sample.xlsm

フォルダ内のファイル名をGrep置換する

https://vbaexcel.slavesystems.com/product/file_grep_sample.xlsm

フォルダ内のExcelファイルの文字列をGrep置換する

https://vbaexcel.slavesystems.com/product/excel_grep_sample.xlsm

※バグがあるかもしれないので、必ずバックアップを取得の上で実行をお願いします。

フォルダ内のテキストファイルの文字列をGrep置換する

例としてフォルダ内にある全てのテキストファイルを開いて、

「いちご」→「みかん」

「ぶどう」→「もも」

という置換をするVBAプログラムを作成してみたいと思います。

シンプルなVBAプログラムサンプル

シンプルなVBAプログラムのサンプルは以下です。

'置換前後の文字列を格納する構造体
Private Type typTargetString
    strBefore As String
    strAfter As String
End Type

'メイン処理
Public Sub grepReplace()
    '置換対象のあるファイルの存在するフォルダ
    Const STR_TARGET_FOLDER As String = "C:\Users\namek\Desktop\test"
    
    '置換対象のファイルの文字コード
    Const STR_CHAR_SET As String = "shift_jis" '"UTF-8"も可 BOM非対応
    
    '置換対象の文字列
    Dim typTargetStrings(1) As typTargetString
    '「いちご」→「みかん」
    typTargetStrings(0).strBefore = "いちご"
    typTargetStrings(0).strAfter = "みかん"
    '「ぶどう」→「もも」
    typTargetStrings(1).strBefore = "ぶどう"
    typTargetStrings(1).strAfter = "もも"
    
    '置換対象のフォルダを取得
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim folder As Object: Set folder = fso.GetFolder(STR_TARGET_FOLDER)
    
    'フォルダの中身をループさせて、各ファイルに対して処理を実行する
    For Each f In folder.Files
        'ファイルを読み込む
        Dim strContent As String: strContent = readFile(f.path, STR_CHAR_SET)
        'ファイルから読み取った文字列を置換する
        Call replaceString(strContent, typTargetStrings)
        'ファイルを書き込む
        Call writeFile(f.path, STR_CHAR_SET, strContent)
    Next f
    Set fso = Nothing
End Sub

Private Sub replaceString(ByRef target, ByRef def() As typTargetString)
    Dim i As Integer
    For i = 0 To UBound(def)
        '置換する文字列の定義の数だけループして文字列を置換する
        target = Replace(target, def(i).strBefore, def(i).strAfter)
    Next i
End Sub

Private Function readFile(filepath As String, charset As String) As String
    '引数で指定されたテキストファイルを開いて、内容の文字列を返す
    Set obj = CreateObject("ADODB.Stream")
    Dim buf As String
    With obj
        .charset = charset
        .Open
        .LoadFromFile filepath
        buf = .ReadText
        .Close
    End With
    readFile = buf
    Set obj = Nothing
End Function

Private Sub writeFile(filepath As String, charset As String, contents As String)
    '引数で指定されたテキストファイルに文字列を書き込む
    Set obj = CreateObject("ADODB.Stream")
    With obj
        .charset = charset
        .Open
        .LoadFromFile filepath
        .WriteText contents, 0
        .SaveToFile filepath, 2
        .Close
    End With
    Set obj = Nothing
End Sub

※バグがあるかもしれないので、必ずバックアップを取得の上で実行をお願いします。

シンプルと言いつつ長くなってしまった。。。

ファイルの入出力があるから仕方がないね><

置換する文字列を変更したいときは、typTargetStringsの配列数を変更した上で定義している値を変えればよいです。

Excel上に置換文字列を指定できるようにする

しかし、このままだとソースを毎回いじらないといけないのでVBAで作るメリットがあまり感じられないです。

そこでExcelのワークシート上に置換文字列を定義できるようにします。また、対象フォルダも定義できるようにします。

サンプルでは上記のようにB6~B15が置換前の文字列、C6~C15が置換後の文字列を定義できる前提で作成します。

作成したVBAプログラムがこちらです。

'対象フォルダのセルのアドレス
Const STR_TARGET_FOLDER_ADDRESS As String = "C2"
'サブフォルダ対象とするのセルのアドレス
Const STR_SUB_FOLDER_ADDRESS As String = "C3"
'置換前文字列のセルのアドレス
Const STR_BEFORE As String = "B6:B15"
'置換前文字列のセルのアドレス
Const STR_AFTER As String = "C6:C15"
'置換対象のファイルの文字コード
Const STR_CHAR_SET As String = "shift_jis" '"UTF-8"も可 BOM非対応

'フォルダピッカーを起動して対象フォルダのセルに値を設定する
Public Sub pickFolder()
    Call setCellFromFolderDialog(ActiveSheet.Range(STR_TARGET_FOLDER_ADDRESS))
End Sub

'メイン処理
Public Sub grepReplace()
    '置換対象のあるファイルの存在するフォルダ
    Dim STR_TARGET_FOLDER As String: STR_TARGET_FOLDER = ActiveSheet.Range(STR_TARGET_FOLDER_ADDRESS).Value
       
    '置換対象の文字列
    Dim typTargetStrings() As typTargetString
    typTargetStrings = getBeforeAfterDef(ActiveSheet.Range(STR_BEFORE), ActiveSheet.Range(STR_AFTER))
    
    'サブフォルダを対象とするかどうか
    Dim bolIsTargetSub As Boolean: bolIsTargetSub = (ActiveSheet.Range(STR_SUB_FOLDER_ADDRESS).Value = "はい")
    
    '各ファイルに対して処理を実行する
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Call replaceAllFiles(STR_TARGET_FOLDER, fso, bolIsTargetSub, typTargetStrings)
    Set fso = Nothing
    MsgBox "終わりました"
End Sub

Private Function replaceAllFiles(path As String, fso As Object, bolIsTargetSub As Boolean, typTargetStrings() As typTargetString)
    Dim folder As Object: Set folder = fso.getFolder(path)
    'サブフォルダの数だけ再帰
    If bolIsTargetSub Then
        For Each subfol In folder.SubFolders
            Call replaceAllFiles(subfol.path, fso, True, typTargetStrings)
        Next subfol
    End If

    'フォルダの中身をループさせて、各ファイルに対して処理を実行する
    For Each f In folder.Files
        'ファイルを読み込む
        Dim strContent As String: strContent = readFile(f.path, STR_CHAR_SET)
        'ファイルから読み取った文字列を置換する
        Call replaceString(strContent, typTargetStrings)
        'ファイルを書き込む
        Call writeFile(f.path, STR_CHAR_SET, strContent)
    Next f

End Function

Private Sub replaceString(ByRef target, ByRef def() As typTargetString)
    Dim i As Integer
    For i = 0 To UBound(def)
        '置換する文字列の定義の数だけループして文字列を置換する
        target = Replace(target, def(i).strBefore, def(i).strAfter)
    Next i
End Sub

'置換前後の文字列を格納する構造体
Public Type typTargetString
    strBefore As String
    strAfter As String
End Type

'置換前後の文字列の定義を取得する
Public Function getBeforeAfterDef(rgBefore As Range, rgAfter As Range) As typTargetString()
    Dim typTargetStrings() As typTargetString
    ReDim typTargetStrings(0)
    Dim intCount As Integer: intCount = 0

    For Each bf In rgBefore
        If bf.Value <> "" Then
            '配列の最大値がすでに埋まっていたら配列を格納
            If typTargetStrings(UBound(typTargetStrings)).strBefore <> "" Then
                ReDim Preserve typTargetStrings(UBound(typTargetStrings) + 1)
            End If
            typTargetStrings(intCount).strBefore = bf.Value
            intCount = intCount + 1
        End If
    Next bf
    
    intCount = 0
    For Each af In rgAfter
        If af.Value <> "" Then
            '配列の最大値がすでに埋まっていたら配列を格納
            If typTargetStrings(UBound(typTargetStrings)).strAfter <> "" Then
                ReDim Preserve typTargetStrings(UBound(typTargetStrings) + 1)
            End If
            typTargetStrings(intCount).strAfter = af.Value
            intCount = intCount + 1
        End If
    Next af
    
     getBeforeAfterDef = typTargetStrings
End Function

'フォルダ選択ダイアログを開き、返却結果をセルに格納する
Public Sub setCellFromFolderDialog(cell As Object)
    cell.Value = showFolderDialog(cell.Value)
End Sub

'フォルダ選択ダイアログを開く
Public Function showFolderDialog(strInit As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = strInit
        If .Show = True Then
            showFolderDialog = .SelectedItems(1)
        End If
    End With
    If showFolderDialog = "" Then
        showFolderDialog = strInit
    End If
End Function

'テキストファイル操作系の関数
Public Function readFile(filepath As String, charset As String) As String
    '引数で指定されたテキストファイルを開いて、内容の文字列を返す
    Set obj = CreateObject("ADODB.Stream")
    Dim buf As String
    With obj
        .charset = charset
        .Open
        .LoadFromFile filepath
        buf = .ReadText
        .Close
    End With
    readFile = buf
    Set obj = Nothing
End Function

Public Sub writeFile(filepath As String, charset As String, contents As String)
    '引数で指定されたテキストファイルに文字列を書き込む
    Set obj = CreateObject("ADODB.Stream")
    With obj
        .charset = charset
        .Open
        .LoadFromFile filepath
        .WriteText contents, 0
        .SaveToFile filepath, 2
        .Close
    End With
    Set obj = Nothing
End Sub

※バグがあるかもしれないので、必ずバックアップを取得の上で実行をお願いします。

課題としては、フォルダの中にバイナリファイルがあった場合にはバグになるということですね。(ファイルがぶっ壊れるかもしれない)

その時は文字コードを判断して、ファイルの種類を見極めるのが良いかと思います。

文字コードの判断は以下の記事で解説しています。


フォルダ内のファイル名をGrep置換する

先程はファイルの内容でしたが、次はフォルダ内にあるファイル名を置き換えていくVBAプログラムを作成したいと思います。

テキスト内容のGrep置換のツールと同じく、下記のようなレイアウトのシートから定義を取得する前提で作成します。

まあ先程のプログラムとほぼ同じですが…、VBAコードは以下のとおりです。

'対象フォルダのセルのアドレス
Const STR_TARGET_FOLDER_ADDRESS As String = "C2"
'サブフォルダ対象とするのセルのアドレス
Const STR_SUB_FOLDER_ADDRESS As String = "C3"
'置換前文字列のセルのアドレス
Const STR_BEFORE As String = "B6:B15"
'置換前文字列のセルのアドレス
Const STR_AFTER As String = "C6:C15"

'フォルダピッカーを起動して対象フォルダのセルに値を設定する
Public Sub pickFolder()
    Call setCellFromFolderDialog(ActiveSheet.Range(STR_TARGET_FOLDER_ADDRESS))
End Sub

'メイン処理
Public Sub grepReplace()
    '置換対象のあるファイルの存在するフォルダ
    Dim STR_TARGET_FOLDER As String: STR_TARGET_FOLDER = ActiveSheet.Range(STR_TARGET_FOLDER_ADDRESS).Value
       
    '置換対象の文字列
    Dim typTargetStrings() As typTargetString
    typTargetStrings = getBeforeAfterDef(ActiveSheet.Range(STR_BEFORE), ActiveSheet.Range(STR_AFTER))
    
    'サブフォルダを対象とするかどうか
    Dim bolIsTargetSub As Boolean: bolIsTargetSub = (ActiveSheet.Range(STR_SUB_FOLDER_ADDRESS).Value = "はい")
    
    '各ファイルに対して処理を実行する
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Call replaceAllFiles(STR_TARGET_FOLDER, fso, bolIsTargetSub, typTargetStrings)
    Set fso = Nothing
    MsgBox "終わりました"
End Sub

Private Function replaceAllFiles(path As String, fso As Object, bolIsTargetSub As Boolean, typTargetStrings() As typTargetString)
    Dim folder As Object: Set folder = fso.getFolder(path)
    'サブフォルダの数だけ再帰
    If bolIsTargetSub Then
        For Each subfol In folder.SubFolders
            Call replaceAllFiles(subfol.path, fso, True, typTargetStrings)
        Next subfol
    End If

    'フォルダの中身をループさせて、各ファイルに対して処理を実行する
    For Each f In folder.Files
        'ファイル名取得
        Dim strFileName As String: strFileName = f.Name
        'ファイル名の文字列を置換する
        Call replaceString(strFileName, typTargetStrings)
        'ファイル名変更
        f.Name = strFileName
    Next f

End Function

Private Sub replaceString(ByRef target, ByRef def() As typTargetString)
    Dim i As Integer
    For i = 0 To UBound(def)
        '置換する文字列の定義の数だけループして文字列を置換する
        target = Replace(target, def(i).strBefore, def(i).strAfter)
    Next i
End Sub

'置換前後の文字列を格納する構造体
Public Type typTargetString
    strBefore As String
    strAfter As String
End Type

'置換前後の文字列の定義を取得する
Public Function getBeforeAfterDef(rgBefore As Range, rgAfter As Range) As typTargetString()
    Dim typTargetStrings() As typTargetString
    ReDim typTargetStrings(0)
    Dim intCount As Integer: intCount = 0

    For Each bf In rgBefore
        If bf.Value <> "" Then
            '配列の最大値がすでに埋まっていたら配列を格納
            If typTargetStrings(UBound(typTargetStrings)).strBefore <> "" Then
                ReDim Preserve typTargetStrings(UBound(typTargetStrings) + 1)
            End If
            typTargetStrings(intCount).strBefore = bf.Value
            intCount = intCount + 1
        End If
    Next bf
    
    intCount = 0
    For Each af In rgAfter
        If af.Value <> "" Then
            '配列の最大値がすでに埋まっていたら配列を格納
            If typTargetStrings(UBound(typTargetStrings)).strAfter <> "" Then
                ReDim Preserve typTargetStrings(UBound(typTargetStrings) + 1)
            End If
            typTargetStrings(intCount).strAfter = af.Value
            intCount = intCount + 1
        End If
    Next af
    
     getBeforeAfterDef = typTargetStrings
End Function

'フォルダ選択ダイアログを開き、返却結果をセルに格納する
Public Sub setCellFromFolderDialog(cell As Object)
    cell.Value = showFolderDialog(cell.Value)
End Sub

'フォルダ選択ダイアログを開く
Public Function showFolderDialog(strInit As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = strInit
        If .Show = True Then
            showFolderDialog = .SelectedItems(1)
        End If
    End With
    If showFolderDialog = "" Then
        showFolderDialog = strInit
    End If
End Function

フォルダ内のExcelファイルの文字列をGrep置換する

今まではテキストファイルがフォルダ内に存在している前提のプログラムでしたが、今回はExcelファイルが対象の場合のVBAプログラムにしたいと思います。

'対象フォルダのセルのアドレス
Const STR_TARGET_FOLDER_ADDRESS As String = "C2"
'サブフォルダ対象とするのセルのアドレス
Const STR_SUB_FOLDER_ADDRESS As String = "C3"
'置換前文字列のセルのアドレス
Const STR_BEFORE As String = "B6:B15"
'置換前文字列のセルのアドレス
Const STR_AFTER As String = "C6:C15"

'フォルダピッカーを起動して対象フォルダのセルに値を設定する
Public Sub pickFolder()
    Call setCellFromFolderDialog(ActiveSheet.Range(STR_TARGET_FOLDER_ADDRESS))
End Sub

'メイン処理
Public Sub grepReplace()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '置換対象のあるファイルの存在するフォルダ
    Dim STR_TARGET_FOLDER As String: STR_TARGET_FOLDER = ActiveSheet.Range(STR_TARGET_FOLDER_ADDRESS).Value
       
    '置換対象の文字列
    Dim typTargetStrings() As typTargetString
    typTargetStrings = getBeforeAfterDef(ActiveSheet.Range(STR_BEFORE), ActiveSheet.Range(STR_AFTER))
    
    'サブフォルダを対象とするかどうか
    Dim bolIsTargetSub As Boolean: bolIsTargetSub = (ActiveSheet.Range(STR_SUB_FOLDER_ADDRESS).Value = "はい")
    
    '各ファイルに対して処理を実行する
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Call replaceAllFiles(STR_TARGET_FOLDER, fso, bolIsTargetSub, typTargetStrings)
    Set fso = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "終わりました"
End Sub

Private Function replaceAllFiles(path As String, fso As Object, bolIsTargetSub As Boolean, typTargetStrings() As typTargetString)
    Dim folder As Object: Set folder = fso.getFolder(path)
    'サブフォルダの数だけ再帰
    If bolIsTargetSub Then
        For Each subfol In folder.SubFolders
            Call replaceAllFiles(subfol.path, fso, True, typTargetStrings)
        Next subfol
    End If

    'フォルダの中身をループさせて、各ファイルに対して処理を実行する
    For Each f In folder.Files
        Dim strExt As String: strExt = fso.GetExtensionName(f.path)
        If strExt = "xls" Or strExt = "xlsx" Or strExt = "xlsm" Then
            Dim wb As WorkBook: Set wb = getWorkBook(f.path)
            wb.Activate
            Call replaceString(wb, typTargetStrings)
            wb.Save
            wb.Close
        End If
    Next f

End Function

Private Sub replaceString(target As WorkBook, def() As typTargetString)
    Dim i As Integer
    For i = 0 To UBound(def)
        '置換する文字列の定義の数だけループして文字列を置換する
        Cells.Replace What:=def(i).strBefore, Replacement:=def(i).strAfter, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Next i
End Sub

'置換前後の文字列を格納する構造体
Public Type typTargetString
    strBefore As String
    strAfter As String
End Type

'置換前後の文字列の定義を取得する
Public Function getBeforeAfterDef(rgBefore As Range, rgAfter As Range) As typTargetString()
    Dim typTargetStrings() As typTargetString
    ReDim typTargetStrings(0)
    Dim intCount As Integer: intCount = 0

    For Each bf In rgBefore
        If bf.Value <> "" Then
            '配列の最大値がすでに埋まっていたら配列を格納
            If typTargetStrings(UBound(typTargetStrings)).strBefore <> "" Then
                ReDim Preserve typTargetStrings(UBound(typTargetStrings) + 1)
            End If
            typTargetStrings(intCount).strBefore = bf.Value
            intCount = intCount + 1
        End If
    Next bf
    
    intCount = 0
    For Each af In rgAfter
        If af.Value <> "" Then
            '配列の最大値がすでに埋まっていたら配列を格納
            If typTargetStrings(UBound(typTargetStrings)).strAfter <> "" Then
                ReDim Preserve typTargetStrings(UBound(typTargetStrings) + 1)
            End If
            typTargetStrings(intCount).strAfter = af.Value
            intCount = intCount + 1
        End If
    Next af
    
     getBeforeAfterDef = typTargetStrings
End Function

'フォルダ選択ダイアログを開き、返却結果をセルに格納する
Public Sub setCellFromFolderDialog(cell As Object)
    cell.Value = showFolderDialog(cell.Value)
End Sub

'フォルダ選択ダイアログを開く
Public Function showFolderDialog(strInit As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = strInit
        If .Show = True Then
            showFolderDialog = .SelectedItems(1)
        End If
    End With
    If showFolderDialog = "" Then
        showFolderDialog = strInit
    End If
End Function

'WorkBook取得処理
Public Function getWorkBook(path As String) As WorkBook
    Dim buf As String
    buf = Dir(path)
        For Each wb In Workbooks
        If wb.Name = buf Then
            Set getWorkBook = wb
            Exit Function
        End If
    Next wb
    
    Set getWorkBook = Workbooks.Open(path)
    Dir (vbNullString)
End Function

※バグがあるかもしれないので、必ずバックアップを取得の上で実行をお願いします。

正直Excelの場合は、開く時に色々考慮しないといけないことが多いので、そのへんのトラブルが多そうですね。

今回のVBAプログラムは、問題なく開けるパターンで試しています。


コメントを残す

メールアドレスが公開されることはありません。

日本語が含まれない投稿は無視されますのでご注意ください。(スパム対策)