Sub SearchTextInWordDocument()
' 必要な変数の宣言
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim selectedFile As Variant
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim searchText As String
Dim searchCount As Long
' ユーザーにファイル選択ダイアログを表示し、.docxファイルを選択させる
selectedFile = Application.GetOpenFilename("Word Documents (*.docx), *.docx", , "Select a Word Document")
' ファイルが選択されたか確認
If selectedFile = False Then Exit Sub
' Wordアプリケーションを開く
Set wordApp = New Word.Application
' 選択されたWord文書を開く
Set wordDoc = wordApp.Documents.Open(selectedFile)
' Excelのシート1を設定
Set ws = ThisWorkbook.Sheets("Sheet1")
' A列の最終行を取得
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' 2行目から最終行までループし、各行のテキストをWord文書で検索
For i = 2 To lastRow
searchText = ws.Cells(i, 1).Value
' 指定されたテキストの出現回数をカウントし、B列に記録
searchCount = CountWordOccurrences(wordDoc, searchText)
ws.Cells(i, 2).Value = searchCount
Next i
' Word文書を保存して閉じる
wordDoc.Close True
' Wordアプリケーションを閉じる
wordApp.Quit
' オブジェクトを解放
Set wordDoc = Nothing
Set wordApp = Nothing
' 完了メッセージを表示
MsgBox "検索が完了しました。", vbInformation
End Sub
Function CountWordOccurrences(doc As Word.Document, searchText As String) As Long
' 必要な変数の宣言
Dim range As Word.Range
Dim count As Long
count = 0
' Word文書の内容全体を範囲として設定
Set range = doc.Content
With range.Find
' 検索設定
.Text = searchText ' 検索するテキスト
.Format = False ' フォーマットは使用しない
.MatchCase = False ' 大文字と小文字の区別をしない
.MatchWholeWord = True ' 単語全体に一致するものだけを検索
.MatchWildcards = False ' ワイルドカードは使用しない
.MatchSoundsLike = False ' 類似音は考慮しない
.MatchAllWordForms = False ' すべての単語形式に一致するものを検索しない
' 文書内を検索し、一致する箇所をカウント
Do While .Execute(Forward:=True, Wrap:=Word.WdFindWrap.wdFindContinue)
' 検索に一致した箇所にピンクのハイライトを適用
range.HighlightColorIndex = Word.WdColorIndex.wdPink
count = count + 1
Loop
End With
' 出現回数を返す
CountWordOccurrences = count
End Function
