リストにある複数の単語をWordで検索し、出現回数を表示するマクロ

「ヵ月」や「か月」など、使わないでねと指示されている表記をついつい忘れて使ってしまう、しょうもない翻訳者の私。
そこから脱出するために、使ってはいけない表記をリストから一網打尽で検索するマクロを作ってみた。

Wordの文書内でリストにある単語を検索し、ヒットした単語を黄色でハイライトするとともに、それぞれの単語が何回出現したかを表示するマクロ。

検索したい単語のリストをエクセルで作成し、CSV形式で保存する（ちなみに、このファイルをエクセルで開くと文字化けする。内容を変更したい場合は、ファイルを右クリックして「プログラムから開く」で、ノートパッドや秀丸などのテキストエディタを選択する）。
できたCSVファイルを右クリックし「パスのコピー」をクリックする。
以下のマクロの「ここにCSVファイルのパスを代入」の部分に、このパスを入れる。

参考にしたウェブサイト：
【Word VBA】Findで複数文字の検索を繰り返す方法！蛍光ペンで着色も！http://extan.jp/?p=5569


＝＝＝＝ここから＝＝＝＝
Dim csvFilePass
Dim strBuf As String
Dim tmp As Variant
Dim changeNumber As Integer
Dim myRange As Range
Dim msg As String

'置換リストファイルを指定
csvFilePass = "ここにCSVファイルのパスを代入"

Open csvFilePass For Input As #1

'CSV内の行数分置換処理を繰り返す

Do Until EOF(1)

'1行分のデータを読み込む
Line Input #1, strBuf

'文字列を","で分割
tmp = Split(strBuf, ",")


'検索範囲を設定
Set myRange = ActiveDocument.Range(0, 0)

'単語の出現回数のカウントを0にする
changeNumber = 0

'検索・置換の設定
With myRange.Find
.Text = tmp(0) '検索ワードを代入

'検索がヒットしている間は繰り返す
Do While .Execute = True

myRange.HighlightColorIndex = wdYellow
myRange.Collapse wdCollapseEnd

'出現回数をカウントする
changeNumber = changeNumber + 1

Loop
End With

'実行
Selection.Find.Execute Replace:=wdReplaceAll

'出現回数が0以外の場合は、出現単語と出現回数を記録する。0の場合は記録しない。
If changeNumber > 0 Then
msg = msg & vbCrLf & "「" & tmp(0) & "」の出現回数：" & changeNumber & "回"

End If

Loop
Close #1

'結果をクリップボードにコピー
With CreateObject("Forms.TextBox.1")
.MultiLine = True '複数行入力可
.Text = msg
.selstart = 0
.sellength = .textlength
.Copy
End With

'該当箇所がない場合のメッセージ
If Len(msg) = 0 Then
msg = "該当箇所はありませんでした。"

'該当箇所がある場合のメッセージ（該当単語と出現回数）
Else
msg = msg & vbCrLf & vbCrLf & "この結果はクリップボードに入っていますので、CTRL＋Vでペーストできます。"

End If


MsgBox msg

＝＝＝ここまで＝＝＝