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

Question

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

CaveatEmptor · Accepted Answer

＃３で回答した者です。

語数にもよりますが、春、夏、秋、冬をひとつずつ検索の表に入れておけば変わります。

語数が多ければ下のマクロを試してください。検索する表に「春夏秋冬」とあっても、「春」「夏」「秋」「冬」をひとつずつ検索してフォントを変えていくように変更しました。

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

CaveatEmptor · Answer

＃３で回答した者です。

こちらの書き方が悪くて、すみません。

置換したい文書を先に開いておき、さらに別ファイル（新規文書でも可）を開き、そこに一列の表を描き、セルの中に検索元の文字を入力して下さい。

つまり、文書１（先に開いておくファイル）はフォントを変えたい文書を、文書２（後で開くファイル）はフォントを変えたい文字の一覧になります。これでやってみてください。

また何かありましたら、遠慮なく質問してください。

Wendy02 · Answer

こんにちは。


いまどきは、「第一次水準漢字」とかいう区分けは、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

CaveatEmptor · Answer

回答があまりないようですが、以下のマクロを試してみてください。

マクロを実行するまえに別に新規のワードの文書に１列の表を作って、その表の中にフォントの色を変えたい文字を書き込んでおき、フォントを変えたい文書と同時に開いておく必要があります。

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

imogasi · Answer

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

neKo_deux · Answer

Wordでの作業と仮定して…

> 特定の千種類ほどの単語を

１文字目がＡ
４文字目がＤ
とかなら、マクロを使わずとも１回の置換で可能な気もしますが…。

普通は、１つの単語に対する処理を千回ほど繰り返せば良いだけです。
苦労するのは、質問者さんでなくてＰＣなんですから…。

--
１回の処理を記録して、記録したSubのモジュールを引数指定できるよう修正し、予め準備してある単語を元に、Excelなんかで単語を引数にして単語数回分Callする処理を作成とか。

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

＃３で回答した者です。

＃３で回答した者です。

この回答への補足

こんにちは。

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

この回答への補足

Wordの１語句（単語）の置換のVBAコード例は、WEB照会で、沢山出てきます。

この回答への補足

Wordでの作業と仮定して…

この回答への補足

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング