Excel VBAで Wordの文をすべて抽出

概要

• Excel VBAで指定されたWord文書からすべての文を抽出して、配列に格納するためのコードを作成しました。
• 以下の動画で使われているものです。

実行環境

以下の環境で動作確認をしました。

• Windows11でのExcel 2021

注意点

• プログラムの実行については、すべて自己責任で行ってください。実行により発生した、いかなる直接的または間接的被害について、作者はその責任を負いません。

コード

VBA

Option Explicit

Sub TestExtractSentences()
    ' Wordファイルのパスを指定
    Dim filePath As String
    filePath = _
    "Your_Path"
    
    ' ExtractSentencesFromWordFile 関数を呼び出して文を取得
    Dim sentencesArray As Variant
    sentencesArray = ExtractSentencesFromWordFile(filePath)

    Dim i As Integer
    For i = LBound(sentencesArray) To UBound(sentencesArray)
        ' 配列の各要素をデバッグ表示
        Debug.Print "Index " & i & ": " & sentencesArray(i)
    Next i
End Sub


' Wordファイルの文章の中から文をすべて抽出して、配列として返す
Function ExtractSentencesFromWordFile(ByVal filePath As String) As Variant
    Dim objWord As Object
    Dim objDoc As Object
    Dim sentenceArray() As String
    Dim sentenceCount As Integer
    Dim i As Integer
    Dim sentence As String    
    ' Wordファイルが既に開かれていないか確認
    Call CheckIfWordFileIsOpen(filePath)

    ' Wordアプリケーションの新しいインスタンスを作成
    Set objWord = CreateObject("Word.Application")

    ' Wordアプリケーションの表示を非表示にする
    objWord.Visible = False

    ' 指定されたWordドキュメントを開く
    Set objDoc = objWord.Documents.Open(filePath)

    ' 変数の初期化
    sentenceCount = 0
    
    ' ドキュメント内の各文に対してループ
    For i = 1 To objDoc.Sentences.count
        ' 文を取得
        sentence = objDoc.Sentences(i).Text
        ' 文のカウントを増やす
        sentenceCount = sentenceCount + 1
        ' 配列をリサイズして新しい文を収めるスペースを作成
        ReDim Preserve sentenceArray(1 To sentenceCount)
        ' 配列に文を格納（改行は削除）
        sentenceArray(sentenceCount) = Replace(sentence, vbCr, "")
    Next i

    ' Wordドキュメントを閉じる
    objDoc.Close

    ' オブジェクト参照を解放
    Set objDoc = Nothing
    Set objWord = Nothing

    ' 文の配列を戻り値として返す
    ExtractSentencesFromWordFile = sentenceArray
End Function


' 指定のWordファイルが既に開かれているか確認
Function CheckIfWordFileIsOpen(ByVal filePath As String) As Boolean
    ' 関連するオブジェクトの宣言
    Dim wordApp As Object
    Dim doc As Object
    
    ' エラーが発生してもスクリプトの実行を続行
    On Error Resume Next
    ' 既存のWordアプリケーションがあるか確認
    Set wordApp = GetObject(, "Word.Application")
    ' エラーハンドリングを元に戻す
    On Error GoTo 0
    
    ' Wordアプリケーションが存在する場合
    If Not wordApp Is Nothing Then
        ' 開かれている全てのドキュメントに対して処理を実行
        For Each doc In wordApp.Documents
            If doc.Path & "\" & doc.Name = filePath Then
                ' ファイルが開かれている場合はTrueを返し、関数を終了
                CheckIfWordFileIsOpen = True
                ' 既に開かれている場合はメッセージを表示し、処理を中止
                MsgBox "指定されたWordファイルは既に開かれています。ファイルを閉じてから再度実行してください。"
                End
            End If
        Next doc
    Else
        ' Wordアプリケーションが実行されていない場合
    End If
    
    ' オブジェクトの解放
    Set doc = Nothing
    Set wordApp = Nothing
End Function