【図解】ワード文書の内容をエクセルに出力するワードマクロ

このマクロは、ワード文書の内容をエクセルに出力するワードマクロ（Word VBA）です。

このマクロを実行すると、ワード文書内のテキスト、表、テキストボックスの内容がエクセルファイルに出力されます。

テキストは、改行単位で出力されます。

このマクロは、この記事の最後にあるコードをコピペするだけで使えます。

マクロの概要

このマクロの概要をイラストで示します。

ワンクリックで、ワード文書の内容がエクセルファイルに出力されます。

マクロの使用方法

各自のワードファイルを開きます

内容を出力したいワードファイルを開きます。

今回の例では、以下のワードファイルを開きました。

マクロの実行ボタンをクリックします

ワード文書画面の左上にあるマクロ実行ボタンをクリックします。

以下のメッセージがでます。

「はい」を選択すると出力処理が始まります。

処理状況は、以下のように、ワード画面左下のステータスバー上に表示されます。

処理中は、以下のように表示されます。

処理が終了すると、以下のメッセージがでます。

出力されるエクセルファイルは、デスクトップ上に作成されます。

エクセルファイルの名前は、「ワードファイル名_エクスポート.xlsx」になります。

既に同名のファイルがある場合は、末尾に番号が付いて別ファイルとして出力されます。

出力エクセルファイル

出力エクセルにおいてワードファイルの内容は、「テキスト内容」、「テキストボックス」、「表」のシートに分かれます。

以下は、「テキスト内容」シートのフォーマットです。

A列：改行単位が存在するページ数

B列：改行単位が存在する行数

C列：改行単位の文字数（空白含む）

D列：改行単位の文字数（空白除く）

E列：改行単位（テキスト）

以下は、「テキストボックス」シートの内容です。

「テキストボックス」シートのフォーマットは、「テキスト内容」シートと同じです。

以下は、「表」シートの内容です。

「表」シートは、表の数だけ生成されます。

画像は出力されません。

画像が存在する位置には、「テキスト内容」シート中で「/」が入ります。

マクロの使用準備

以下の手順を行うことで、各自のワードファイルから本マクロを簡単に呼び出せるようになります。

１．別の記事に記載したステップ①の手順０～６までを実施した後、ステップ①の手順７で、この記事の最後にあるコードを標準モジュールのＭodule1にコピペします。

２．ステップ①の８から２２を行います

（ステップ①の１１では、以下のマクロ名を選択してから、追加ボタンを押してください）

Project.Module1.ExportWordContentToExcel

（ステップ①の１３では、お好きなアイコンを選んでください）

（ステップ①の２０での保存名は何でもかまいません）

（ステップ①の２２の次に記載されている「動作確認」はスキップしていただいてかまいません）

３．ステップ②を行います

ステップ②を行うことで、このマクロをどのワード文書からも呼び出せるようになります。

（このステップ②を行うと、各自のワードファイルを開いた際に、各自が選んだマクロアイコンがワード文書の左上に表示されるようになります）

以上で、マクロを使用する準備が整いました！

マクロの削除

本マクロが不要になった場合は、こちらの手順でdotmファイルごと削除してください。

別の変換方法

マクロを使用しなくてもワードファイルをエクセルに変換できます（エクセル中のフォーマットは、本マクロの場合とは異なります）。

マクロなしでのエクセルへの変換方法は、別の記事をご参照ください。

マクロのコード

以下は、本マクロのコードです。

上の説明（マクロの使用準備）にあるように標準モジュールにコピペしてご使用ください。

（以下のコードをすべて選択して、そのまま貼り付けてください）

現在の公開バージョンは、V01L01（公開日：2025/6/24）です。

Sub ExportWordContentToExcel()
    ' V01L01
    Dim wdDoc As Document
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim desktopPath As String
    Dim excelFileName As String
    Dim fullPath As String
    Dim i As Long, j As Long, k As Long
    Dim shapeContent As String
    Dim tbl As Table
    Dim tableCount As Integer
    Dim FSO As Object
    Dim textLines() As String
    Dim currentLine As String
    Dim pageNum As Long
    Dim lineNum As Long
    Dim rng As Range
    Dim charCountWithSpaces As Long
    Dim charCountWithoutSpaces As Long
    Dim docRng As Range
    Dim paraRng As Range
    Dim textBoxCounter As Long
    Dim hasTextContent As Boolean
    Dim hasTextBoxes As Boolean
    Dim hasTables As Boolean
    
    ' 現在開いているWordドキュメントを取得
    Set wdDoc = ActiveDocument
    
    ' ドキュメントに変更があるかチェック
    If Not wdDoc.Saved Then
        ' 変更がある場合、ユーザーに保存を促す
        If MsgBox("ドキュメントに保存されていない変更があります。" & vbCrLf & _
                 "続行する前に保存してください。" & vbCrLf & vbCrLf & _
                 "今すぐ保存しますか？", vbQuestion + vbYesNo + vbDefaultButton2, "保存の確認") = vbYes Then
            wdDoc.Save
        Else
            MsgBox "処理を中止します。変更を保存してから再度実行してください。", vbInformation
            Exit Sub
        End If
    End If
    
    ' この時点でまだ変更がある場合は処理を中止
    If Not wdDoc.Saved Then
        MsgBox "ドキュメントが保存されていません。変更を保存してから再度実行してください。", vbExclamation
        Exit Sub
    End If
    
    ' ユーザーに確認
    If MsgBox("Wordドキュメントの内容をExcelに出力します。続行しますか？", vbQuestion + vbYesNo + vbDefaultButton2, "処理の確認") = vbNo Then
        Exit Sub
    End If
    
    ' 処理状況表示
    Application.StatusBar = "処理を開始します..."
    
    ' 変更を記録しないようにする
    Application.ScreenUpdating = False
    
    ' 出力対象があるか先に確認する
    hasTextContent = False
    hasTextBoxes = False
    hasTables = (wdDoc.Tables.Count > 0)
    
    ' テキスト内容の確認
    For i = 1 To wdDoc.Paragraphs.Count
        Set paraRng = wdDoc.Paragraphs(i).Range
        
        ' 段落が表の中にあるかチェック
        Dim isInTable As Boolean
        isInTable = False
        On Error Resume Next
        If Not (paraRng.Tables.Count = 0) Then
            isInTable = True
        End If
        On Error GoTo 0
        
        ' 段落がテキストボックス内にあるかチェック
        Dim isInTextBox As Boolean
        isInTextBox = False
        On Error Resume Next
        If paraRng.ShapeRange.Count > 0 Then
            isInTextBox = True
        End If
        On Error GoTo 0
        
        ' 表やテキストボックス内にない段落のみ処理
        If Not isInTable And Not isInTextBox Then
            currentLine = Trim(paraRng.Text)
            If currentLine <> "" And currentLine <> Chr(13) Then
                ' 末尾の段落記号を削除
                If Right(currentLine, 1) = Chr(13) Then
                    currentLine = Left(currentLine, Len(currentLine) - 1)
                End If
                
                If Trim(currentLine) <> "" Then
                    hasTextContent = True
                    Exit For
                End If
            End If
        End If
    Next i
    
    ' テキストボックスの確認
    For i = 1 To wdDoc.Shapes.Count
        If wdDoc.Shapes(i).Type = 17 Then ' テキストボックス
            On Error Resume Next
            shapeContent = wdDoc.Shapes(i).TextFrame.TextRange.Text
            On Error GoTo 0
            
            If Trim(shapeContent) <> "" Then
                hasTextBoxes = True
                Exit For
            End If
        End If
    Next i
    
    ' 出力対象がない場合は処理を終了
    If Not hasTextContent And Not hasTextBoxes And Not hasTables Then
        Application.ScreenUpdating = True
        Application.StatusBar = False
        MsgBox "出力対象となるテキスト内容、テキストボックス、表がありません。", vbInformation, "処理終了"
        Exit Sub
    End If
    
    Application.StatusBar = "Excelアプリケーションを起動中..."
    ' Excelアプリケーションを起動
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    
    ' 新しいExcelブックを作成
    Set xlWB = xlApp.Workbooks.Add
    
    ' デスクトップのパスを取得
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    
    ' 基本ファイル名（Wordドキュメント名をベースに）
    excelFileName = Left(wdDoc.Name, InStrRev(wdDoc.Name, ".") - 1) & "_エクスポート.xlsx"
    fullPath = desktopPath & excelFileName
    
    ' ファイルシステムオブジェクトを作成
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' 同名ファイルが存在する場合は、ファイル名に番号を付ける
    k = 1
    While FSO.FileExists(fullPath)
        excelFileName = Left(wdDoc.Name, InStrRev(wdDoc.Name, ".") - 1) & "_エクスポート(" & k & ").xlsx"
        fullPath = desktopPath & excelFileName
        k = k + 1
    Wend
    
    ' テキスト内容がある場合のみ、テキスト内容シートを作成
    If hasTextContent Then
        Application.StatusBar = "テキスト内容を処理中..."
        ' 最初のシートをテキスト用に設定
        Set xlSheet = xlWB.Sheets(1)
        xlSheet.Name = "テキスト内容"
        
        ' ヘッダー行を設定
        xlSheet.Range("A1").Value = "ページ"
        xlSheet.Range("B1").Value = "行"
        xlSheet.Range("C1").Value = "文字数(空白含む)"
        xlSheet.Range("D1").Value = "文字数(空白除く)"
        xlSheet.Range("E1").Value = "テキスト"
        xlSheet.Range("A1:E1").Font.Bold = True
        
        ' テキスト内容を行ごとに分割してExcelシートに書き込み
        j = 2 ' データ開始行
        
        ' 段落ごとに処理（表とテキストボックス以外のテキストのみ）
        For i = 1 To wdDoc.Paragraphs.Count
            Set paraRng = wdDoc.Paragraphs(i).Range
            
            ' 段落が表の中にあるかチェック
            isInTable = False
            On Error Resume Next
            If Not (paraRng.Tables.Count = 0) Then
                isInTable = True
            End If
            On Error GoTo 0
            
            ' 段落がテキストボックス内にあるかチェック
            isInTextBox = False
            On Error Resume Next
            If paraRng.ShapeRange.Count > 0 Then
                isInTextBox = True
            End If
            On Error GoTo 0
            
            ' 表やテキストボックス内にない段落のみ処理
            If Not isInTable And Not isInTextBox Then
                currentLine = Trim(paraRng.Text)
                If currentLine <> "" And currentLine <> Chr(13) Then
                    ' 末尾の段落記号を削除
                    If Right(currentLine, 1) = Chr(13) Then
                        currentLine = Left(currentLine, Len(currentLine) - 1)
                    End If
                    
                    If Trim(currentLine) <> "" Then
                        ' 文字数をカウント
                        charCountWithSpaces = Len(currentLine)
                        charCountWithoutSpaces = Len(Replace(currentLine, " ", ""))
                        
                        ' ページと行番号を取得
                        pageNum = paraRng.Information(wdActiveEndPageNumber)
                        lineNum = paraRng.Information(wdFirstCharacterLineNumber)
                        
                        xlSheet.Cells(j, 1).Value = pageNum
                        xlSheet.Cells(j, 2).Value = lineNum
                        xlSheet.Cells(j, 3).Value = charCountWithSpaces
                        xlSheet.Cells(j, 4).Value = charCountWithoutSpaces
                        xlSheet.Cells(j, 5).Value = currentLine
                        j = j + 1
                    End If
                End If
            End If
            
            ' 10段落ごとに処理状況を更新
            If i Mod 10 = 0 Then
                Application.StatusBar = "テキスト内容を処理中... " & Format(i / wdDoc.Paragraphs.Count, "0%")
            End If
        Next i
        
        ' 列幅を自動調整
        xlSheet.Columns("A:D").ColumnWidth = 15
        xlSheet.Columns("E:E").ColumnWidth = 100
        xlSheet.Columns("E:E").WrapText = True
    Else
        ' テキスト内容がない場合は最初のシートを削除する前に保持
        Dim firstSheet As Object
        Set firstSheet = xlWB.Sheets(1)
    End If
    
    ' テキストボックスがある場合のみ、テキストボックスシートを作成
    If hasTextBoxes Then
        Application.StatusBar = "テキストボックスを処理中..."
        ' テキストボックスの内容を取得して書き込み
        If hasTextContent Then
            Set xlSheet = xlWB.Sheets.Add(After:=xlWB.Sheets(xlWB.Sheets.Count))
        Else
            Set xlSheet = xlWB.Sheets(1) ' テキスト内容がない場合は最初のシートを使用
        End If
        xlSheet.Name = "テキストボックス"
        
        ' ヘッダー行を設定
        xlSheet.Range("A1").Value = "テキストボックス番号"
        xlSheet.Range("B1").Value = "ページ"
        xlSheet.Range("C1").Value = "行"
        xlSheet.Range("D1").Value = "文字数(空白含む)"
        xlSheet.Range("E1").Value = "文字数(空白除く)"
        xlSheet.Range("F1").Value = "テキスト"
        xlSheet.Range("A1:F1").Font.Bold = True
        
        j = 2 ' データ開始行
        textBoxCounter = 1 ' テキストボックスのカウンターを1から開始
        
        ' すべての形状（シェイプ）を確認
        For i = 1 To wdDoc.Shapes.Count
            If wdDoc.Shapes(i).Type = 17 Then ' テキストボックス
                shapeContent = ""
                
                ' テキストボックスのテキストを取得
                On Error Resume Next
                shapeContent = wdDoc.Shapes(i).TextFrame.TextRange.Text
                On Error GoTo 0
                
                If Trim(shapeContent) <> "" Then
                    ' テキストボックスの内容を行ごとに分割
                    textLines = Split(shapeContent, vbCr)
                    
                    ' テキストボックスの位置情報を取得
                    Set rng = wdDoc.Range(wdDoc.Shapes(i).Anchor.Start, wdDoc.Shapes(i).Anchor.Start)
                    pageNum = rng.Information(wdActiveEndPageNumber)
                    lineNum = rng.Information(wdFirstCharacterLineNumber)
                    
                    ' 各行を書き込み
                    For k = 0 To UBound(textLines)
                        currentLine = Trim(textLines(k))
                        If currentLine <> "" Then
                            ' 文字数をカウント
                            charCountWithSpaces = Len(currentLine)
                            charCountWithoutSpaces = Len(Replace(currentLine, " ", ""))
                            
                            xlSheet.Cells(j, 1).Value = textBoxCounter  ' iではなくtextBoxCounterを使用
                            xlSheet.Cells(j, 2).Value = pageNum
                            xlSheet.Cells(j, 3).Value = lineNum + k
                            xlSheet.Cells(j, 4).Value = charCountWithSpaces
                            xlSheet.Cells(j, 5).Value = charCountWithoutSpaces
                            xlSheet.Cells(j, 6).Value = currentLine
                            j = j + 1
                        End If
                    Next k
                    
                    textBoxCounter = textBoxCounter + 1 ' テキストボックスを処理したらカウンターを増やす
                End If
            End If
            
            ' シェイプ処理状況を更新
            Application.StatusBar = "テキストボックスを処理中... " & Format(i / wdDoc.Shapes.Count, "0%")
        Next i
        
        ' 列幅を自動調整
        xlSheet.Columns("A:E").ColumnWidth = 15
        xlSheet.Columns("F:F").ColumnWidth = 100
        xlSheet.Columns("F:F").WrapText = True
    ElseIf Not hasTextContent Then
        ' テキスト内容もテキストボックスもない場合、最初のシートを保持
        Set xlSheet = firstSheet
    End If
    
    ' 表の内容を取得して書き込み
    tableCount = wdDoc.Tables.Count
    
    If tableCount > 0 Then
        Application.StatusBar = "表を処理中..."
        ' 各表を別シートに
        For i = 1 To tableCount
            Application.StatusBar = "表 " & i & "/" & tableCount & " を処理中..."
            
            Set tbl = wdDoc.Tables(i)
            Set xlSheet = xlWB.Sheets.Add(After:=xlWB.Sheets(xlWB.Sheets.Count))
            xlSheet.Name = "表" & i
            
            ' 表の位置情報を取得
            Set rng = tbl.Range
            pageNum = rng.Information(wdActiveEndPageNumber)
            
            ' シートの一番上に表の位置情報を表示
            xlSheet.Range("A1").Value = "ページ: " & pageNum
            xlSheet.Range("A1").Font.Bold = True
            
            ' 表のデータをExcelに転送（開始行を2に）
            For j = 1 To tbl.Rows.Count
                For k = 1 To tbl.Columns.Count
                    On Error Resume Next
                    xlSheet.Cells(j + 1, k).Value = tbl.Cell(j, k).Range.Text
                    xlSheet.Cells(j + 1, k).Value = Replace(xlSheet.Cells(j + 1, k).Value, Chr(13), "")
                    xlSheet.Cells(j + 1, k).Value = Replace(xlSheet.Cells(j + 1, k).Value, Chr(7), "")
                    On Error GoTo 0
                Next k
            Next j
            
            ' 列幅を自動調整
            xlSheet.Columns.AutoFit
        Next i
    End If
    
    ' テキスト内容もテキストボックスもなく、最初のシートがまだ存在する場合は削除
    If Not hasTextContent And Not hasTextBoxes And tableCount > 0 Then
        On Error Resume Next
        firstSheet.Delete
        On Error GoTo 0
    End If
    
    Application.StatusBar = "Excelファイルを保存中..."
    
    ' 最初のシートを選択状態にする
    xlWB.Sheets(1).Select
    
    ' Excelファイルを保存して閉じる
    xlWB.SaveAs fullPath
    xlWB.Close
    
    ' Excelアプリケーションを終了
    xlApp.Quit
    
    ' オブジェクトを解放
    Set xlSheet = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Set FSO = Nothing
    
    ' マクロ実行中に変更が発生した場合に元の状態に戻す
    If wdDoc.Saved = False Then
        wdDoc.Saved = True
    End If
    
    ' 画面更新を元に戻す
    Application.ScreenUpdating = True
    
    ' ステータスバーを更新
    Application.StatusBar = "処理が終了しました"
    
    ' 完了メッセージ
    MsgBox "Wordドキュメントの内容を以下に保存しました: " & vbCrLf & fullPath, vbInformation, "エクスポート完了"
End Sub