マクロを使いワードの置換で特定の千種類の単語のフォント色を変えたい

質問

「マクロ」を使ってワードの「置換」機能で特定の千種類ほどの単語を一括で「フォント色」を「赤」に変えたいのですがどうすればよいでしょうか？

回答No.6

CaveatEmptor · ベストアンサー

＃３で回答した者です。

語数にもよりますが、春、夏、秋、冬をひとつずつ検索の表に入れておけば変わります。

語数が多ければ下のマクロを試してください。検索する表に「春夏秋冬」とあっても、「春」「夏」「秋」「冬」をひとつずつ検索してフォントを変えていくように変更しました。

Sub ReplaceFontColor()
Dim rngFind As Range
Dim row As row
Dim rowReplace As Rows
Dim MyLen As Integer
winNo = Windows.Count
With Selection
Set rowReplace = Windows(winNo).Document.Tables(1).Rows
For Each row In rowReplace
Set rngFind = row.Cells(1).Range
rngFind.MoveEnd Unit:=wdCharacter, Count:=-1
MyLen = Len(rngFind)
For j = 1 To MyLen
SingleLetter = Mid(rngFind, j, 1)
With Selection.Find
.ClearFormatting
.Wrap = wdFindStop
.Text = SingleLetter
.MatchByte = True
.MatchCase = True
.MatchWholeWord = True
.Replacement.Font.ColorIndex = wdRed
.Execute Replace:=wdReplaceAll
End With
Next
Next
End With
End Sub

お礼

有難うございます。おっしゃるとおり上手くいきました。何度も質問に丁寧に答えていただき感謝感激です。本当に有難うございました。
次は、1000字以上の置換を実際にやってみたいと思います。

回答No.5

CaveatEmptor

＃３で回答した者です。

こちらの書き方が悪くて、すみません。

置換したい文書を先に開いておき、さらに別ファイル（新規文書でも可）を開き、そこに一列の表を描き、セルの中に検索元の文字を入力して下さい。

つまり、文書１（先に開いておくファイル）はフォントを変えたい文書を、文書２（後で開くファイル）はフォントを変えたい文字の一覧になります。これでやってみてください。

また何かありましたら、遠慮なく質問してください。

補足

とんでもございません。理解力不足で申し訳ないです。
「文書2」にたとえば（春夏秋冬）と記入し、「文書1」にちりばめられた（春夏秋冬）は赤くなったのですが、（春）（夏）（秋）（冬）と1文字ずつちりばめた単語には変化がないのです。
つまり、1単語or1熟語のみを一度に変換したいのではなく、1000種類の個別の漢字を元に1000種類の漢字が別々にちりばめられた文章の中から検索し一字ずつ赤に変換したいのです。
物分りが悪いのかもしれませんがよろしくお願いいたします。

回答No.4

Wendy02

こんにちは。

いまどきは、「第一次水準漢字」とかいう区分けは、Wordにはないので、一旦、文字コードを換えてあげないと出来ませんね。それと、Wordの能力一杯一杯です。Wordは、意外に、マクロのパワーがないような気がします。

また、外字の区分けは、Wordにはありませんから、特別の文字コードを検索するようになります。こちらでは、外字領域に、ハングルが現れてきています。

'Option Explicit
Public Const MYCOLOR As Long = wdColorRed　'色-赤
Sub JISCodeLettersSearch()
'JIS検索プログラム
'JIS第一水準漢字を探すマクロ
Dim mySelection As Selection
Dim TowByte() As String
Dim j As Long
Dim i As Long
Dim ltr As String
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Set mySelection = Selection
　For i = 1 To Len(mySelection)
　　ltr = Mid$(mySelection, i, 1)
　　　If Asc(ltr) >= &H889F And Asc(ltr) <= &H9872 Then
　　　　ReDim Preserve TowByte(j)
　　　　TowByte(j) = ltr
　　　　j = j + 1
　　　End If
　Next i
　If j = 0 Then MsgBox "単語は見つかりません。", vbInformation: Exit Sub
　Application.ScreenUpdating = False
　For j = 0 To UBound(TowByte)
　　　WordHilightPrc TowByte(j)
　Next
　Application.ScreenUpdating = True
　Options.DefaultHighlightColorIndex = wdNoHighlight
　Selection.HomeKey Unit:=wdStory
End Sub
Sub WordHilightPrc(ByVal myStr As String)
　　Selection.Find.ClearFormatting
　　Selection.Find.Replacement.ClearFormatting
　　Selection.Find.Replacement.Highlight = True
　　With Selection.Find
　　　　.Text = myStr
　　　　.Replacement.Text = myStr
　　　　.Replacement.Font.Color = MYCOLOR
　　　　.Forward = True
　　　　.Wrap = wdFindContinue
　　　　.Format = True
　　　　.MatchCase = False
　　　　.MatchWholeWord = False
　　　　.MatchByte = False
　　　　.MatchAllWordForms = False
　　　　.MatchSoundsLike = False
　　　　.MatchWildcards = False
　　　　.MatchFuzzy = False
　　End With
　　Selection.Find.Execute Replace:=wdReplaceAll
End Sub

'Unicode 検索

"[\u3041-\u3094]+"　'ひらがな
"[\ue000-\ue757]+"　'外字

Option Explicit
Sub TwoByteStrFindProc()
'Unicode検索プログラム
'要設定：参照設定 Microsoft VBScript Regular Expressions
Dim objRegExp As New RegExp
Dim mySelection As Selection
Dim Matches As Object
Dim Match
Dim TowByte()
Dim sLength As Long
Dim i As Long
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Set mySelection = Selection
　　With objRegExp
　　　　.Global = True
　　　　.IgnoreCase = True
　　　　.Pattern = "[\u3041-\u3094]+"　'ひらがな検索
　　　　Set Matches = .Execute(mySelection)
　　　　sLength = 0
　　End With
　　For Each Match In Matches
　　　　　　 ReDim Preserve TowByte(i)
　　　　　　 TowByte(i) = Match.Value
　　　　　　 i = i + 1
　　Next Match
　　If Matches.Count = 0 Then MsgBox _
　　"該当する検索文字が見つかりません", 64: Exit Sub
　　Application.ScreenUpdating = False
　　For i = 0 To UBound(TowByte)
　　　WordHilightPrc TowByte(i)
　　Next
　　Application.ScreenUpdating = True
　　 Selection.HomeKey Unit:=wdStory
End Sub

お礼

有難うございました。今回の私の質問テーマとは直接すぐに役に立たなかったのですが、せっかく丁寧に回答していただきましたので、じっくり眺めて勉強してみたいと思います。本当に有難うございました。

回答No.3

CaveatEmptor

回答があまりないようですが、以下のマクロを試してみてください。

マクロを実行するまえに別に新規のワードの文書に１列の表を作って、その表の中にフォントの色を変えたい文字を書き込んでおき、フォントを変えたい文書と同時に開いておく必要があります。

Sub ReplaceFontColor
Dim rngFind As Range
Dim row As row
Dim rowReplace As Rows
winNo = Windows.Count
With Selection
Set rowReplace = Windows(winNo).Document.Tables(1).Rows
For Each row In rowReplace
Set rngFind = row.Cells(1).Range
rngFind.MoveEnd Unit:=wdCharacter, Count:=-1
With Selection.Find
.ClearFormatting
.Wrap = wdFindStop
.Text = rngFind.Text
.MatchByte = True
.MatchCase = True
.MatchWholeWord = True
.Replacement.Font.ColorIndex = wdRed
.Execute Replace:=wdReplaceAll
End With
Next
End With
End Sub

補足

初心者なので、変な質問もお許しくださいね。
ワード「文書1」「文書2」と2つ開いておき、
「文書1」に一列の表を描きセルの中に検索元の複数の漢字を入力します。
「文書2」に赤色に変更したい文字を含んだより多数の一群の漢字を入力しておきます。
文書2のVBEにReplaceFontColor()コードをコピペします。
こうしてやってみたのですが、何の変化も起こりません。どこの操作が間違っているのでしょうか？

回答No.2

imogasi

Wordの１語句（単語）の置換のVBAコード例は、WEB照会で、沢山出てきます。
＃１でおっしゃっているように、「＞千種類ほどの単語」とスラッというが、（１）どういう状態で存在するのか（例えばテキストファイルにあるのか）、（２）個別にその都度入力するのか（３）一遍に（１回の実行で）別々の１０００単語の文字色を一斉に変えるのか、（４）必要の都度数語を置換し、別の機会に何度も行うのか（４）1000語に共通性があるのか（ワイルドカードを使って表されるような）
最悪１０００回置換ルーチンを繰り返しか？
プログラムを組む人はそちらに興味（心配、課題、解決すべき問題点）があると思う、と思う。
すなわち、上記質問は不完全と思う。

補足

おっしゃるとおり不完全な質問で申し訳御座いません。
例えば　第一次水準漢字が記入されたファイルを基にして、第一次水準漢字・第二次水準漢字・外字・ひらかな・カタカナ等が１万字ほどランダムに混在するファイルの中から第一次水準漢字のみを選びその漢字をすべて一度にフォント色を赤に変えるにはどうすればよいのでしょうか？あるいは外字とひらかなが記入されたファイルを基に同じように第一次水準漢字・第二次水準漢字・外字・ひらかな・カタカナ等が１万字ほどランダムに混在するファイルの中から外字とひらかながのみを選びそれらをすべて一度にフォント色を赤に変えるにはどうすればよいのでしょうか？

回答No.1

neKo_deux

Wordでの作業と仮定して…

> 特定の千種類ほどの単語を

１文字目がＡ
４文字目がＤ
とかなら、マクロを使わずとも１回の置換で可能な気もしますが…。

普通は、１つの単語に対する処理を千回ほど繰り返せば良いだけです。
苦労するのは、質問者さんでなくてＰＣなんですから…。

--
１回の処理を記録して、記録したSubのモジュールを引数指定できるよう修正し、予め準備してある単語を元に、Excelなんかで単語を引数にして単語数回分Callする処理を作成とか。

補足

質問内容が不完全でした。申し訳御座いません。
> 特定の千種類ほどの単語
具体的には千種類ほどの漢字を別ファイル（A）に記入してあります。
他方1万種類ほどの漢字が記入されたファイル(B)があります。
ファイル(B)の中からファイル(A)に有る漢字と一致した漢字をフォント色「黒」から「赤」に一度に変換したいのです。

>１回の処理を記録して、記録したSubのモジュールを引数指定できるよう修正し、予め準備してある単語を元に、Excelなんかで単語を引数にして単語数回分Callする処理を作成とか。

初心者なのでここのところがわかりません。

Sub フォントを赤に()
'
' フォントを赤に Macro
' 記録日 2007/01/25 記録者 xxxx
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "黒"
.Replacement.Font.Color = wdColorRed
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
このマクロで「黒」という文字のフォント色を（赤）に変えることは出来たのですが、他のファイルに有る千種類の漢字をどう読み込むか分からないですし、修正した段階で上記のマクロがうまく作動するか自信ありません。