Wordファイルの文字列を置換するExcel VBA

伊藤貴洋と申します。

とりあえずVBAを開発してみました。

昔（2013年ころ）は、Word VBA等の情報が少なかった気がしますが、

今は、沢山の情報があるから、VBAで困ることは少なそうですねって

自分で開発をしていて思いました。

あと、自分の開発したプログラムを公開するって、

勇気がいるモノだなぁ・・・、と少しこのnoteは緊張感があります。

前置きはさておき、

ExcelからWordファイルの文字列を置換するツールを開発してみました。

開発していて気づいたのですが、

ExcelのUIの連携等をどうしたモノかと考え込んでしまいましたが、

一例として画像としてみました。

【設定方法】

A列の２行目以降に置換前の文字列を入力してください。

C列の２行目以降に置換後の文字列を入力してください。

行で置換する様に作ってあります。

１行目のどこかの行のセルの名前を

「Wordファイルパス」と変更してください。

このサンプルの場合は、

F1のセルを「Wordファイルパス」と変更しています。

このサンプルの場合は、ボタンを設置して、

ボタンにVBAのプロシージャ—を登録して、

実行できるようにしてあります。

プログラムは以下になります。

「ALT」＋「F11」などで、VBAのプロジェクトを立ち上げて、

上記を設定したシートに以下のVBAをコピペしてください。

'Wordファイルのパスを指定するセルの名前
Private Const STR_WORD_FILE_PATH_CELL_NAME As String = "Wordファイルパス"

'置換文字列のシーク用の定数
Private Const I_START_COL_BEFORE As Integer = 1
Private Const I_START_COL_AFTER As Integer = 3
Private Const I_START_ROW As Integer = 2

'Wordファイルを選択するボタン
Public Sub WordFileSelect()

    Dim objFD As Variant
    
    Set objFD = Application.FileDialog(msoFileDialogFilePicker)
    
    With objFD
    
        '決定ボタンの名前を変える（新しいバージョンの場合、無効な模様）
        .ButtonName = "選択"
        .Title = "Wordファイルを選択してください。"
        '複数のファイル選択をすることを抑止する
        .AllowMultiSelect = False
    
        With .Filters
            '初期条件を消す
            .Clear
            'フィルターにWordファイルを追加する
            .Add "Wordファイル", "*.doc; *.docx; *.docm"
        End With
        
        If .Show = True Then
            '開き終わったら、選択したファイルパスを指定のセルにセットする
            Range(STR_WORD_FILE_PATH_CELL_NAME).Value = .SelectedItems(1)
        End If
    
    End With
    
    '念のため初期化
    Set objFD = Nothing

End Sub

'置換処理を実行するボタン
Public Sub WordFileStringReplace()

    If MsgBox("全てのWordファイルを閉じてから実行してください。" & vbCrLf & "全てのWordファイルを閉じましたか？", vbYesNo, ThisWorkbook.Name) = vbNo Then
    
        Exit Sub
    
    End If

    Dim strWordPath As String
    
    'セルの文字列を文字列変数に代入する
    strWordPath = Range(STR_WORD_FILE_PATH_CELL_NAME).Value

    If strWordPath = "" Then
        MsgBox "Wordファイルを選択してください。", vbExclamation, ThisWorkbook.Name
        Exit Sub
    End If
    
    'Wordファイルの拡張子である事を確認する
    If LCase(Right(strWordPath, 4)) <> ".doc" And _
       LCase(Right(strWordPath, 5)) <> ".docx" And _
       LCase(Right(strWordPath, 5)) <> ".docm" Then
       
        MsgBox "Wordファイルを選択してください。", vbExclamation, ThisWorkbook.Name
        Exit Sub
              
    End If

On Error GoTo ErrWord

    'ツール→参照設定で「Microsoft Word 00 Object Library」のチェックをいれると利用できる
    Dim objWordApp As Word.Application
    Dim objWordDocument As Word.Document
    
    Dim r As Long
    
    r = I_START_ROW
    
    Dim strBefore As String
    Dim strAfter As String
    
    Set objWordApp = New Word.Application
    
    objWordApp.Visible = True
    
    Set objWordDocument = objWordApp.Documents.Open(strWordPath)
    
    '空白の置換があり得ると思うから
    '置換前の文字列が続く限り置き換え処理を続ける
    Do While Cells(r, I_START_COL_BEFORE) <> ""
    
        strBefore = Cells(r, I_START_COL_BEFORE)
        strAfter = Cells(r, I_START_COL_AFTER)
        
        '他の方のサイトを参考に処理を繕いました
        'Wordファイルの文字列を検索して置換する処理一式です
        objWordDocument.ActiveWindow.Selection.Find.ClearFormatting
        objWordDocument.ActiveWindow.Selection.Find.Replacement.ClearFormatting
        
        With objWordDocument.ActiveWindow.Selection.Find
        
             .Text = strBefore
             .Replacement.Text = strAfter
             .Forward = True
             .Wrap = wdFindContinue
             .Format = False
             .MatchCase = True
             .MatchWholeWord = False
             .MatchByte = True
             .MatchAllWordForms = False
             .MatchSoundsLike = False
             .MatchWildcards = False
             .MatchFuzzy = False

        End With
        
        objWordDocument.ActiveWindow.Selection.Find.Execute Replace:=wdReplaceAll
    
        r = r + 1
        
    Loop
    
    MsgBox "置換が完了しました！", vbInformation, ThisWorkbook.Name
    
    '保存するかどうかのダイアログ画面を表示させる
    objWordApp.Quit
    
    Set objWordApp = Nothing
    Set objWordDocument = Nothing
        
    Exit Sub
    
ErrWord:

    MsgBox "エラーが発生しました" & vbCrLf & "エラー番号[" & Err.Number & "]" & vbCrLf & "エラーメッセージ[" & Err.Description & "]", vbCritical, ThisWorkbook.Name

    objWordApp.Quit
    
    Set objWordApp = Nothing
    Set objWordDocument = Nothing

End Sub

コピペしたら、

①WordFileSelectを実行する

②WordFileStringReplaceを実行する

で動くと思います。

実行後は、Wordを閉じるように、設定してあります。

置換が行われた場合、変更がありますが、保存しますか？

の様なダイアログが発生すると思います。

適宜の判断をお願い致します。

キャンセルして別名で保存して、

コンペア等をとって頂き、ご確認されることを推奨いたします。

Wordファイルは、あらかじめバックアップをとっておくと、

安心だと思いますので、このプログラムを実行する前に、

慣れるまでは、バックアップをとられることを推奨します。

（あまりテストできていないので、自信が無いです。。。）

このVBAの開発環境は、

Windows 7で、Excel 2010になります。

Macの場合は、動かないかもしれません。

また、根本的に、動かない場合は、

VBAのプロジェクト（「ALT」＋「F11」）から

ツール→参照設定で「Microsoft Word XX Object Library」の

チェックを入れてみて下さい。

以下は私の環境の例です。

何かありましたらご意見等、頂けると嬉しいです。

宜しくお願い致します。