VBAテンプレート Wordの文字列検索

検索対象の文字列(複数可)がWordのファイルにいくつ記載されているか検索をするツールです。自分が会社で使うように投稿します。

ほとんどChatGTPに作ってもらいました。

実施方法の説明

1. A列に検索したい文字列を書きます。複数行設定可能です。
2. E列に検索対象のファイルのフルパスを書きます。「ファイル名検索」ボタンでファイルパスを追加することもできます。※VBA：Sub ファイル検索()
3. 検索処理を実行したい場合は「検索」ボタンを押下します。※VBA：Sub CountWordMatches()
   「大文字小文字の区別して検索をしたい場合『はい』を選択してください」とポップアップが出るので「はい」か「いいえ」を押下してください。
   検索完了後、F列に検索結果が出力されます。出力形式は「検索単語：検索ヒット数,」で出力されます。

• 注意事項
  • マクロの処理が重い場合、Excelが落ちる可能性があります。ほかに開いているファイルがあれば処理の前に保存しておくことをおすすめします。
  • 検索範囲はWordの本文と図形の中に記載された文章です。Wordに張り付けられた画像内の文字列は確認できません。
  • E列の中にファイル検索不要の行がある場合、D列に「不要」を記載すると検索処理がスキップされます。

シートの作成

Excelシートは1シートのみです。
「ファイル一覧」シート

★「ファイル一覧」シートを作成

「ファイル一覧」シートに表は２つ作成します。
表は５列目にタイトル
６列目以降に値が入ります

表1　検索文字列と置換文字列一覧
A列：検索したい文字列一覧

表2　操作ファイルとその結果
D列：操作の要否（操作不要なら「不要」を記載）
E列：操作したいファイルのフルパス
F列：検索結果(セルのアドレスと値)

★マクロボタンの追加
「ファイル検索(複数可)」ボタン：ファイル検索
「検索」ボタン：Sub CountWordMatches

ソースコード

• Word検索処理

Sub CountWordMatches()
    Dim wordApp As Object ' Word.Application
    Dim wordDoc As Object ' Word.Document
    Dim searchText As String
    Dim searchResult As String
    Dim foundRange As Object ' Word.Range
    Dim matchCount As Long
    
    Dim mySheet As Variant
    Set mySheet = ThisWorkbook.Sheets("ファイル一覧")
    
    Dim searchChar As Boolean
    
    searchChar = False
    If MsgBox("大文字小文字の区別して検索をしたい場合『はい』を選択してください", vbYesNo) = vbYes Then searchChar = True
    
    ' Wordアプリケーションを作成
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False ' Wordアプリケーションを表示するかどうか
    
    For file_i = 6 To mySheet.Range("E10000").End(xlUp).Row
    
    If mySheet.Range("D" & file_i).Value = "不要" Then ' 実施不要の場合の判定
    
    mySheet.Range("F" & file_i).Value = "実施不要"
    GoTo skip
    
    Else
    
        Dim docPath As String
        docPath = mySheet.Range("E" & file_i).Value
    
        If Not CreateObject("Scripting.FileSystemObject").FileExists(docPath) Then
            GoTo エラー
        End If
    
        ' Wordドキュメントを読み取り専用で開く
        Set wordDoc = wordApp.Documents.Open(docPath, ReadOnly:=True)
        
        For seach_i = 6 To mySheet.Range("A10000").End(xlUp).Row
        
            ' 検索する文字列を格納
            searchText = mySheet.Range("A" & seach_i).Value
            
            If searchText = "" Then
                GoTo skip_serch
            End If
            
            '文字列を検索する処理を実行
            matchCount = SearchTextInRanges(wordDoc, searchText, searchChar)
            
            '図形内の文字列を検索する処理を実行
            matchCount = matchCount + SearchTextInShapes(wordDoc, searchText, searchChar)

            
            ' ヒットした件数を格納
            searchResult = searchResult & searchText & ":" & matchCount & ","
skip_serch:

         Next seach_i
        
        ' 結果を記入,wordを閉じる
        mySheet.Range("F" & file_i).Value = searchResult
        searchResult = ""
        wordDoc.Close
        Set wordDoc = Nothing
        
        GoTo skip
    End If ' 実施不要の場合のIF文終了
    
エラー:
   
    mySheet.Range("F" & file_i).Value = "ファイル開かず"
skip:
    
    Next file_i
    
    ' WordAppを終了
    wordApp.Quit
    Set wordApp = Nothing
    
    MsgBox ("処理が終了しました。")
    
End Sub

• 処理中に呼び出す関数

'本文の検索
Function SearchTextInRanges(wordDoc As Object, searchText As String, searchChar As Boolean) As Integer

    Dim matchCount As Integer
    matchCount = 0
    ' テキスト検索を実行
    With wordDoc.Content.Find
        .ClearFormatting     ' 検索条件をクリアして、新しい検索を開始する際に不要なフォーマットを削除します。
        .Text = searchText   ' 検索する文字列を設定します。
        .MatchWholeWord = False ' 単語全体として一致するかどうかを設定します。True であれば、単語全体での一致を検索します。
        .MatchCase = searchChar    ' 大文字と小文字を区別するかどうかを設定します。True であれば、大文字と小文字を区別して検索します。
        .Forward = True      ' 検索の方向を設定します。True であれば、前方向 (文書の末尾から先頭へ) に検索します。
        .Wrap = 0            ' 検索のラップ モードを設定します。0 (wdFindStop) であれば、検索は1回だけ実行されます。
        .Replacement.Text = ""
        Do While .Execute
            matchCount = matchCount + 1
        Loop
    End With
    
    SearchTextInRanges = matchCount
End Function

'図形内の文章の検索
Function SearchTextInShapes(wordDoc As Object, searchText As String, searchChar As Boolean) As Integer

    Dim matchCount As Integer
    matchCount = 0
    Dim addNum As Integer
    Dim strVal As String
    
    Dim shape As Object
    For Each shape In wordDoc.Shapes
        If shape.TextFrame.HasText Then
            strVal = shape.TextFrame.TextRange.Text
            
            If searchChar Then
                addNum = (Len(strVal) - Len(Replace(strVal, searchText, ""))) / Len(searchText) '文字列を完全一致で検索する。
            Else
                addNum = (Len(strVal) - Len(Replace(strVal, searchText, "", compare:=vbTextCompare))) / Len(searchText) '大文字小文字関係なく検索する
            End If
            
            matchCount = matchCount + addNum
        End If
    Next shape
        
    SearchTextInShapes = matchCount
End Function

• Wordファイル検索処理

Sub ファイル検索()

Dim ファイル一覧シート As Variant
Set ファイル一覧シート = ThisWorkbook.Sheets("ファイル一覧")

    Dim 選択ファイル As Variant
    Dim f As Variant
    
    ChDir "C:"
    選択ファイル = Application.GetOpenFilename( _
         FileFilter:="Word ファイル (*.doc; *.docx), *.doc; *.docx", _
         MultiSelect:=True)
         
Dim filei As Integer
    
    If IsArray(選択ファイル) Then
        filei = ファイル一覧シート.Range("E10000").End(xlUp).Row + 1
        For Each ファイル In 選択ファイル
            ファイル一覧シート.Range("E" & filei) = ファイル
            filei = filei + 1
        Next
    End If


End Sub