マイクロソフトのワードで、複数の単語を連続して置換する方法を探しています。

Wordのマクロですがこちらをおためしください。

とりあえず、今２，３分で作ったマクロなので拡張性は少ないですが、これでできます。

Sub Test()

Dim i As Integer

Dim A$(1)

Dim B$(1)

A$(0) = ”企画”: B$(0) = ”規格”

A$(1) = ”取り扱い”: B$(1) = ”取扱い”

For i = 0 To 1

Cells.Replace What:=A$(i), Replacement:=B$(i)

Next

End Sub

以前同じようなツールをWordのVBAで書きました。置換リストをテーブルに書いたWordを用意します（ただし1行目はヘッダーとする）。この文書から以下のスクリプトを実行する。

ちょっと解読が面倒かもしれませんが、ReplaceDという関数で実際の置換を行っています。各セクションのContentsとHeaderとFooterを対象にそれぞれ実行しなければならなかったと記憶しています。

あと、下記のスクリプトでは、ツールのWordファイルを置いたディレクトリにあるすべてのDOCファイルに対して同じ処理をするというものです。適当に加工してください。

置換を実行する前に編集履歴をONにすることも簡単だと思います。

’ Global variables

Dim fs As New FileSystemObject

Dim before(100) As String

Dim after(100) As String

’ The main replace tool entry point

Sub ReplaceA()

Dim doc As Document

Dim tbl As Table

’ Get active document, which is this tool

Set doc = ActiveDocument

Set tbl = doc.Tables(1)

’ Get the ”before” and ”after” replacment text sets

For i = 2 To tbl.Rows.Count

text1$ = tbl.Cell(i, 1).Range.Text

text2$ = tbl.Cell(i, 2).Range.Text

If (Len(text1$) > 2 And Len(text2$) > 2) Then

before(i - 2) = Left(text1$, Len(text1$) - 2)

after(i - 2) = Left(text2$, Len(text2$) - 2)

End If

Next

Call ReplaceB(doc.Path)

End Sub

’ Helper sub #1

Sub ReplaceB(loc As String)

Dim fld As Folder

Dim sfld As Folder

Dim f As File

Set fld = fs.GetFolder(loc)

For Each f In fld.Files

If UCase(Right(f.Name, 3)) = ”DOC” And Not (f.Name = ActiveDocument.Name) And Not Left(f.Name, 1) = ”~” Then

Call ReplaceC(f.Path)

End If

Next

End Sub

’ Helper sub #2

Sub ReplaceC(fp As String)

Dim wdoc As Document

Dim r As Range

Dim bFound As Boolean

Dim sec As Section

Dim i As Integer

’ Open the target document

Set wdoc = Documents.Open(fp)

’ Use the replacement rules to replace all text pairs in the content, headers and footers

For i = 0 To UBound(before) - 1

If Not before(i) = ”” Then

Call ReplaceD(wdoc.Content, before(i), after(i))

For Each sec In wdoc.Sections

Call ReplaceD(sec.Headers(wdHeaderFooterFirstPage).Range, before(i), after(i))

Call ReplaceD(sec.Headers(wdHeaderFooterPrimary).Range, before(i), after(i))

Call ReplaceD(sec.Footers(wdHeaderFooterPrimary).Range, before(i), after(i))

Next

End If

Next

’ Save the document

wdoc.Save

wdoc.Close

End Sub

’ Helper sub #3

Sub ReplaceD(r As Range, src As String, tgt As String)

With r.Find

.Text = src

.ClearFormatting

.Replacement.Text = tgt

.Execute Replace:=wdReplaceAll, Forward:=True, MatchCase:=True

End With

End Sub

’ Button function

Private Sub CommandButton1_Click()

Call ReplaceA

End Sub

シェアウェアですが、試用期間が

ありますので、試されてみては

いかがでしょうか？