2024年6月5日 / 最終更新日時 : 2024年6月5日 alljapan Excel

指定したフォルダ内のWordファイルを検索し、特定の文字列が含まれている場所をExcelの検索結果シートに記録します

タイトルのマクロは、以下です。

'このマクロは、指定したフォルダ内のWordファイルを検索し、
'特定の文字列が含まれている場所（ページ番号、行番号）を検索結果シートに記録します。
'検索文字列ごとに繰り返し処理を行い、各検索文字列ごとに新しいシートを作成します。
'検索結果はシートに記録され、各行には検索文字列、ファイル名、ページ番号、行番号、文字数、および該当する文章が記録されます。
' 最後にWordアプリケーションを終了します。
'
'このマクロはMicrosoft Wordを使用しますので、実行する前に必要な参照設定を行ってください。
'また、"ひな形"という名前のシートが必要です。これは、検索結果を記録するためのテンプレートとして使用されます。
'
'マクロの実行時には､mainサブルーチンを呼び出すことで処理が開始されます｡


Dim wordApp As Word.Application ' Wordアプリケーションのオブジェクト変数
Dim wordDoc As Word.Document    ' Wordドキュメントのオブジェクト変数
Dim ws As Worksheet             ' 検索結果を記録するワークシート
Dim fileName As String          ' ファイル名
Dim serchStr As String          ' 検索文字

' 検索結果シートの列
Enum clm
    検索文字列列 = 1
    ファイル名列
    ページ番号列
    行番号列
    文字数列
    文章列
    [_Last]         ' 最後の列（使用されないが列挙の終了を示す）
End Enum

Sub main()
    Call wordを開く                 ' Wordアプリケーションを開くサブルーチンを呼び出す
    Call 検索文字ごとに繰り返す     ' 検索文字ごとに繰り返すサブルーチンを呼び出す
    Call wordを閉じる               ' Wordアプリケーションを閉じるサブルーチンを呼び出す
End Sub

Private Sub wordを開く()
    Set wordApp = New Word.Application      ' Wordアプリケーションオブジェクトを作成
    wordApp.Visible = True                  ' Wordアプリケーションを表示する
End Sub

Private Sub 検索文字ごとに繰り返す()
    Dim rng As Range
    ' セルに名前「検索文字」が付けられている範囲をループ
    For Each rng In wsMacro.Range("検索文字")
        serchStr = rng.Value
        If serchStr <> "" Then
            Call 検索文字ごとの処理   ' 検索文字ごとの処理サブルーチンを呼び出す
        End If
    Next rng
End Sub

Private Sub 検索文字ごとの処理()
    ' 検索文字ごとに、その検索文字をシート名にする
    Call シート作成
    ' 指定したフォルダ内のWordファイルに対して、同じ処理をする
    Call ProcessFilesInFolder(ThisWorkbook.Path)
End Sub


' 指定したフォルダ内のWordファイルに対して、同じ処理をする
Private Sub ProcessFilesInFolder(ByVal folderPath As String)
    Dim fso As Object
    Dim wb As Workbook
    Dim file As Variant
    
    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダ内の各ファイルに対して処理
    For Each file In fso.GetFolder(folderPath).Files
        If LCase(Right(file.Name, 5)) = ".docx" Or _
            LCase(Right(file.Name, 4)) = ".doc" Then                            ' Wordファイルの拡張子を確認
            Set wordDoc = wordApp.Documents.Open(file.Path, ReadOnly:=True)     ' Wordドキュメントを開く
            fileName = file.Name                                                ' ファイル名を保持する
            Call 文字列を検索してページ番号と行番号を取得する                   ' 文字列を検索してページ番号と行番号を取得するサブルーチンを呼び出す
            wordDoc.Close                                                       ' Wordドキュメントを閉じる
            Set wordDoc = Nothing                                               ' Wordドキュメントオブジェクトを解放する
        End If
    Next file
End Sub


Private Sub シート作成()
    ' 検索文字を、シート名とする
    Dim sheetName As String
    sheetName = serchStr
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' コピーしたシートを右端に追加する
    wb.Worksheets("ひな形").Copy After:=Worksheets(Worksheets.Count)
    ' 右端のシートを、オブジェクト変数に入れる
    Set ws = wb.Worksheets(Worksheets.Count)    ' 追加したシートを変数に代入する
    
    ' シートが存在していれば、削除
    If ExistSheet(sheetName, wb) Then
        Application.DisplayAlerts = False
        wb.Worksheets(sheetName).Delete
        Application.DisplayAlerts = True
    End If
    ws.Name = sheetName     ' シート名を検索文字に設定する
End Sub

'*************************
'* シートが存在しているかどうか確認する関数。存在する場合は、Trueを返す
'* shetName：調べたいシート名を指定
'* book：調べたいワークブックを指定
Private Function ExistSheet(ByVal sheetName As String, ByVal book As Workbook) As Boolean
    Dim ws As Worksheet, flag As Boolean
    ' すべてのワークシートを表す Worksheets コレクションからひとつずつ
    ' Worksheetを取り出して、名前を確認します。
    For Each ws In book.Worksheets
        If ws.Name = sheetName Then flag = True
    Next ws
    
    ExistSheet = flag
End Function


Private Sub wordを閉じる()
    wordApp.Quit
    Set wordApp = Nothing
End Sub

' https://www.relief.jp/docs/word-vba-find-get-page-line-numbers.html
Private Sub 文字列を検索してページ番号と行番号を取得する()
    
    Dim rng As Word.Range
    Set rng = wordDoc.Range(0, 0)
    
    rng.Find.Text = serchStr    ' 検索文字
    rng.Find.MatchCase = False  ' 大文字と小文字を区別しない
    rng.Find.MatchByte = False  ' 文字の全角と半角を区別せず
    
    
    ' 検索結果シートの行数
    Dim rw As Long
    ' 最終行取得
    rw = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    ' wordの文字数
    Dim lastCharacter As Long
    lastCharacter = wordDoc.Characters.Count
    
    ' 前回の文章を保持
    Dim strOutputBefore As String

    Do While rng.Find.Execute
        Dim startPos As Long
        Dim endPos As Long
        startPos = rng.Start    ' 検索文字の開始位置
        endPos = rng.End        ' 検索文字の終了位置
        
        ' 検索文字の開始位置から、前に向かって、改行or"。"を検索し、その位置を、文章の頭にする
        Dim i As Long
        For i = startPos To 2 Step -1
            Dim str  As String
            str = wordDoc.Range(i - 1, i)
            If str = "。" Or str = vbCr Then
                startPos = i
                Exit For
            End If
        Next i
        
        ' 検索文字の終了位置から、最後の文字に向かって、改行or"。"を検索し、その位置を、文章の終わりにする
        i = endPos
        Do
            str = wordDoc.Range(i - 1, i)
            If str = "。" Or str = vbCr Then
                endPos = i
                Exit Do
            End If
            i = i + 1
        Loop Until i > lastCharacter
        
        ' 検索文字を含んだ文章
        Dim strOutput As String
        strOutput = wordDoc.Range(startPos, endPos)
        
        ' 前回の文章と違う場合のみ、記録する
        If strOutput <> strOutputBefore Then
            ' シートに検索結果を入力
            ws.Cells(rw, clm.検索文字列列) = serchStr
            ws.Cells(rw, clm.ファイル名列) = fileName
            ws.Cells(rw, clm.ページ番号列) = rng.Information(wdActiveEndAdjustedPageNumber)
            ws.Cells(rw, clm.行番号列) = rng.Information(wdFirstCharacterLineNumber)
            ws.Cells(rw, clm.文字数列) = rng.Start
            ws.Cells(rw, clm.文章列) = strOutput
            ' 行をプラス1
            rw = rw + 1
        End If
                
        ' 前回の文章を保持
        strOutputBefore = strOutput
    Loop
End Sub

実行結果を説明します。検索文字は、以下のように、「検索文字」と名前を付けたセルに、入力します。例では、「ビデオ」と「テーマ」が検索文字になっています。

マクロを実行すると、このマクロブックの入ったフォルダから、すべてのWordファイルが検索され、以下のように、結果がシート「ビデオ」にまとまります。今回は、「ダミー.docx」「ダミー2.docx」が検索されるWordファイルになっています。同様に、シート「テーマ」が作成され、検索結果が収まります。

以下にマクロの各部分の詳細な説明を示します。

変数と列挙型の宣言

Dim wordApp As Word.Application ' Wordアプリケーションのオブジェクト変数
Dim wordDoc As Word.Document    ' Wordドキュメントのオブジェクト変数
Dim ws As Worksheet             ' 検索結果を記録するワークシート
Dim fileName As String          ' ファイル名
Dim serchStr As String          ' 検索文字

' 検索結果シートの列
Enum clm
    検索文字列列 = 1
    ファイル名列
    ページ番号列
    行番号列
    文字数列
    文章列
    [_Last]         ' 最後の列（使用されないが列挙の終了を示す）
End Enum

wordApp: Wordアプリケーションオブジェクト。
wordDoc: Wordドキュメントオブジェクト。
ws: 検索結果を記録するワークシート。
fileName: ファイル名を格納する文字列。
serchStr: 検索する文字列を格納する文字列。
Enum clm: 検索結果シートの列番号を定義する列挙型。

mainサブルーチン

Sub main()
    Call wordを開く                 ' Wordアプリケーションを開くサブルーチンを呼び出す
    Call 検索文字ごとに繰り返す     ' 検索文字ごとに繰り返すサブルーチンを呼び出す
    Call wordを閉じる               ' Wordアプリケーションを閉じるサブルーチンを呼び出す
End Sub

main: マクロのメインエントリーポイント。サブルーチンを順番に呼び出して処理を進める。

Wordアプリケーションを開くサブルーチン

Private Sub wordを開く()
    Set wordApp = New Word.Application      ' Wordアプリケーションオブジェクトを作成
    wordApp.Visible = True                  ' Wordアプリケーションを表示する
End Sub

wordを開く: Wordアプリケーションを起動して表示する。

検索文字ごとに繰り返すサブルーチン

Private Sub 検索文字ごとの処理()
    ' 検索文字ごとに、その検索文字をシート名にする
    Call シート作成
    ' 指定したフォルダ内のWordファイルに対して、同じ処理をする
    Call ProcessFilesInFolder(ThisWorkbook.Path)
End Sub

検索文字ごとに繰り返す: 検索文字が格納されているセル範囲をループし、各検索文字に対して処理を行う。

検索文字ごとの処理サブルーチン

Private Sub 検索文字ごとに繰り返す()
    Dim rng As Range
    ' セルに名前「検索文字」が付けられている範囲をループ
    For Each rng In wsMacro.Range("検索文字")
        serchStr = rng.Value
        If serchStr <> "" Then
            Call 検索文字ごとの処理   ' 検索文字ごとの処理サブルーチンを呼び出す
        End If
    Next rng
End Sub

検索文字ごとの処理: 各検索文字ごとにシートを作成し、そのシートに対して処理を行う。

指定フォルダ内のWordファイルを処理するサブルーチン

Private Sub ProcessFilesInFolder(ByVal folderPath As String)
    Dim fso As Object
    Dim wb As Workbook
    Dim file As Variant
    
    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダ内の各ファイルに対して処理
    For Each file In fso.GetFolder(folderPath).Files
        If LCase(Right(file.Name, 5)) = ".docx" Or _
            LCase(Right(file.Name, 4)) = ".doc" Then                            ' Wordファイルの拡張子を確認
            Set wordDoc = wordApp.Documents.Open(file.Path, ReadOnly:=True)     ' Wordドキュメントを開く
            fileName = file.Name                                                ' ファイル名を保持する
            Call 文字列を検索してページ番号と行番号を取得する                   ' 文字列を検索してページ番号と行番号を取得するサブルーチンを呼び出す
            wordDoc.Close                                                       ' Wordドキュメントを閉じる
            Set wordDoc = Nothing                                               ' Wordドキュメントオブジェクトを解放する
        End If
    Next file
End Sub

ProcessFilesInFolder: 指定したフォルダ内のすべてのWordファイルに対して処理を行う。ファイルを開き、検索処理を行い、処理後にファイルを閉じる。

シート作成サブルーチン

Private Sub シート作成()
    ' 検索文字を、シート名とする
    Dim sheetName As String
    sheetName = serchStr
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' コピーしたシートを右端に追加する
    wb.Worksheets("ひな形").Copy After:=Worksheets(Worksheets.Count)
    ' 右端のシートを、オブジェクト変数に入れる
    Set ws = wb.Worksheets(Worksheets.Count)    ' 追加したシートを変数に代入する
    
    ' シートが存在していれば、削除
    If ExistSheet(sheetName, wb) Then
        Application.DisplayAlerts = False
        wb.Worksheets(sheetName).Delete
        Application.DisplayAlerts = True
    End If
    ws.Name = sheetName     ' シート名を検索文字に設定する
End Sub

シート作成: 検索文字に基づいて新しいシートを作成し、既存のシートがあれば削除して新しいシートを命名する。

シート存在確認関数

'*************************
'* シートが存在しているかどうか確認する関数。存在する場合は、Trueを返す
'* shetName：調べたいシート名を指定
'* book：調べたいワークブックを指定
Private Function ExistSheet(ByVal sheetName As String, ByVal book As Workbook) As Boolean
    Dim ws As Worksheet, flag As Boolean
    ' すべてのワークシートを表す Worksheets コレクションからひとつずつ
    ' Worksheetを取り出して、名前を確認します。
    For Each ws In book.Worksheets
        If ws.Name = sheetName Then flag = True
    Next ws
    
    ExistSheet = flag
End Function

ExistSheet: 指定されたシートが存在するかどうかを確認する。存在する場合はTrueを返す。詳細は、以下を参照してください。

シートが存在しているかどうか確認する関数。

Wordアプリケーションを閉じるサブルーチン

Private Sub wordを閉じる()
    wordApp.Quit
    Set wordApp = Nothing
End Sub

wordを閉じる: Wordアプリケーションを終了し、オブジェクトを解放する。

文字列を検索してページ番号と行番号を取得するサブルーチン

Private Sub 文字列を検索してページ番号と行番号を取得する()
    
    Dim rng As Word.Range
    Set rng = wordDoc.Range(0, 0)
    
    rng.Find.Text = serchStr    ' 検索文字
    rng.Find.MatchCase = False  ' 大文字と小文字を区別しない
    rng.Find.MatchByte = False  ' 文字の全角と半角を区別せず
    
    
    ' 検索結果シートの行数
    Dim rw As Long
    ' 最終行取得
    rw = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    ' wordの文字数
    Dim lastCharacter As Long
    lastCharacter = wordDoc.Characters.Count
    
    ' 前回の文章を保持
    Dim strOutputBefore As String

    Do While rng.Find.Execute
        Dim startPos As Long
        Dim endPos As Long
        startPos = rng.Start    ' 検索文字の開始位置
        endPos = rng.End        ' 検索文字の終了位置
        
        ' 検索文字の開始位置から、前に向かって、改行or"。"を検索し、その位置を、文章の頭にする
        Dim i As Long
        For i = startPos To 2 Step -1
            Dim str  As String
            str = wordDoc.Range(i - 1, i)
            If str = "。" Or str = vbCr Then
                startPos = i
                Exit For
            End If
        Next i
        
        ' 検索文字の終了位置から、最後の文字に向かって、改行or"。"を検索し、その位置を、文章の終わりにする
        i = endPos
        Do
            str = wordDoc.Range(i - 1, i)
            If str = "。" Or str = vbCr Then
                endPos = i
                Exit Do
            End If
            i = i + 1
        Loop Until i > lastCharacter
        
        ' 検索文字を含んだ文章
        Dim strOutput As String
        strOutput = wordDoc.Range(startPos, endPos)
        
        ' 前回の文章と違う場合のみ、記録する
        If strOutput <> strOutputBefore Then
            ' シートに検索結果を入力
            ws.Cells(rw, clm.検索文字列列) = serchStr
            ws.Cells(rw, clm.ファイル名列) = fileName
            ws.Cells(rw, clm.ページ番号列) = rng.Information(wdActiveEndAdjustedPageNumber)
            ws.Cells(rw, clm.行番号列) = rng.Information(wdFirstCharacterLineNumber)
            ws.Cells(rw, clm.文字数列) = rng.Start
            ws.Cells(rw, clm.文章列) = strOutput
            ' 行をプラス1
            rw = rw + 1
        End If
                
        ' 前回の文章を保持
        strOutputBefore = strOutput
    Loop
End Sub

文字列を検索してページ番号と行番号を取得するサブルーチンの続き

文字列を検索してページ番号と行番号を取得する: 検索文字列を含む文章を見つけて、そのページ番号と行番号を取得し、Excelシートに記録する。
- 検索範囲設定: Set rng = wordDoc.Range(0, 0) でドキュメント全体を検索対象に設定。
- 検索条件設定: rng.Find.Text = serchStr で検索文字列を設定し、大文字小文字や全角半角を区別しないように設定。
- 検索ループ: Do While rng.Find.Execute で検索を実行し、見つかるたびに処理を行う。
- 文章の開始位置と終了位置の調整: 検索文字列を含む文章全体を特定するために、改行や句点までの範囲を取得。
- 文章の記録: 同じ文章が重複して記録されないようにしつつ、検索結果をシートに記録。
- ページ番号と行番号の取得: rng.Information(wdActiveEndAdjustedPageNumber) と rng.Information(wdFirstCharacterLineNumber) を使用してページ番号と行番号を取得。
- 記録: 検索結果をExcelシートに記録。

以下を参考に作成しました。感謝します。

https://www.relief.jp/docs/word-vba-find-get-page-line-numbers.html

このマクロは以下の手順で動作します：

Wordアプリケーションを開く: Wordアプリケーションを起動して表示。検索文字ごとに繰り返す: 検索文字を順番に処理。シート作成: 検索文字ごとに新しいシートを作成。フォルダ内のWordファイルを処理: 指定フォルダ内のWordファイルを一つずつ開き、指定文字列を検索。検索結果を記録: 検索結果（ページ番号、行番号、文字数、該当する文章）をExcelシートに記録。Wordアプリケーションを閉じる: 処理が終わったらWordアプリケーションを閉じて終了。

これにより、指定フォルダ内のWordファイルから特定の文字列を含むすべての場所を検索し、その結果をExcelに一覧として記録できます。

Follow me!

カテゴリー: Excel、VBA、マクロ、検索