ワード文書中のすべての表をエクセルに出力するマクロ【図解】

このマクロは、ワード文書中のすべての表を自動で抽出し、各シートに１つの表を含むエクセルファイルとしてデスクトップ上に出力（エクスポート）するワードマクロ（Word VBA）です。

ワード文書中に表が大量に存在する場合、そのデータを利用したいと思っても、それを手動で集めるのは大変です。

そんなときに、このマクロを使用すれば、すべての表をエクセルに一括出力できます。

\Word VBAを学べる数少ない一冊 ( ´•ᴗ• ´ ) /

マクロの概要

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

本マクロを実行すると、上のイラストのように、ワード文書中のすべての表がエクセルファイルのシートに個別にエクスポートされます。

エクセルファイルはデスクトップ上に自動で保存されます。

「標準モード」、「テキストモード」、「画像モード」、「テキスト+オブジェクトモード」の４つのモードを選択できます。

マクロの全体の流れ

まず最初に、マクロの使用の全体の流れを以下に示します。

step
1出力したい表を含む各自のワードファイルを開きます

step
2左上に表示される本マクロのアイコンをクリックします

（アイコンの種類は各自が選べます。詳細は、後述の「マクロの使用準備」をご参照ください）

step
3出力モードを選びます

実行したいモードの番号（半角でも全角でも可）をインプットボックスに入力します。

モードは以下の４つです。

• 標準モード
• テキストモード
• 画像モード
• テキスト+オブジェクトモード

番号を入力後に「OK」ボタンを押すと、自動で処理が始まります。

step
4結果のエクセルファイルを確認します

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

メッセージの表示と同時に、以下のイラストのようなエクセルファイルが自動で開きます。

このエクセルファイルは、「標準モード」で処理を実行した場合のものです。

このエクセルファイルは、既にデスクトップ上に保存されています。

出力エクセルファイルの名前は以下になります。

　　「出力元ワードファイルの名前」からの出力_「モード名」_枝番.xlsx

既に同じ名前のファイルがデスクトップ上にある場合は、上書きはされずに枝番が１つ増えた別ファイルとして保存されます。

出力元のワードファイル中に複数の表が含まれている場合、表はエクセルシートごとに分けてに出力されます。

例えば、出力元ワードファイルに表が３つ含まれていた場合、出力先エクセルファイルには、以下のイラストのようにシートが３つできます。

以上が本マクロの全体の流れです！

以下では、各モードの詳細を説明します。

各出力モードの説明

標準モード

標準モードで得られる結果は、ワード中の表を手動でエクセルファイルにコピーした場合と同じです。

以下に、このモードの実行例を示します。

・出力元ワードファイルの表

・出力先エクセルファイルの表

このモードのメリットとデメリットは、以下の通りです。

このモードは、メリットが多いため、もっとも使用需要が高いものと思います。

しかしながら、上の「デメリット」の２番目に示しましたように、ワードのセル中に改行を含む文字列が存在する場合、改行の数の分、エクセルでは勝手にセルが分割されてしまうことは、場合によっては大きなデメリットです。

そのような場合は、次に説明する「テキストモード」が便利です。

テキストモード

以下に、テキストモードの実行例を示します。

・出力元ワードファイルの表

・出力先エクセルファイルの表

このモードのメリットとデメリットは、以下の通りです。

上記のメリットとデメリットを加味して、必要に応じてこのモードを選択してください。

画像モード

以下に、画像モードの実行例を示します。

・出力元ワードファイルの表

・出力先エクセルファイルの表

このモードのメリットとデメリットは、以下の通りです。

ワード中の表が複数ページにまたがっていた場合、表の画像は分割出力されます。

そのため、表の数が多かったり、表が巨大な場合は、出力に時間を要することがあります。

複数ページにまたがる極端に縦長の列（縦列）が表中に存在する場合、出力画像のレイアウトがおかしくなったり、後半の行の出力が行われない場合があります。

テキスト+オブジェクトモード

以下に、テキスト+オブジェクトモードの実行例を示します。

・出力元ワードファイルの表

・出力先エクセルファイルの表

このモードのメリットとデメリットは、以下の通りです。

このモードでは、マクロの内部処理として、「標準モード」を実行後に、シートをクリアしてオブジェクトのみを残し、その後に「テキストモード」を実行しています。

そのため、結果的に、オブジェクトとテキストのデータのみがエクセルに出力されます。

必要に応じてこのモードを選択してください。

捕捉説明

マクロの処理状況の確認

マクロの処理の進行状況は、出力元ワードファイルの左下のステータスバーに、以下のイラストのような感じで表示されます。

処理が終了すると、終了のメッセージと共に、以下のように、ステータスバーに「処理が終了しました」と出ます。

入れ子構造の表

「入れ子構造」とは、以下のイラストの表のように、表の中に表がある構造のことを言います。

・出力元ワードファイルの表（表の中に表を含む表）

上のイラストの入れ子構造の表を各モードで出力した場合の結果は、以下の通りです。

・標準モード

・テキストモード

・画像モード

・テキスト+オブジェクトモード

注意点

・マクロの処理中は、文字や画像のコピペやプリントスクリーン（スクショ）などは行わないでください。

・表を出力したいワードファイルを開いたときに、以下のイラストのように、「編集を有効にする」というボタンが表示された場合、このボタンを押してからマクロを実行してください。

このボタンを押さずにマクロを実行すると、以下のエラーメッセージが出ます。

上記のように、本マクロを実行するには「編集を有効にする」ボタンを押す必要がありますが、これは、単に、本マクロがワードファイルにアクセスできるようにするためのものです。

表の出力元のワードファイルを本マクロが変更することはありません。

本マクロはワードファイルを変更するものではありませんが、念のためワードファイルの事前バックアップをお願いします。

マクロの使用準備

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

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

２．こちらの記事に記載したステップ①の８から２２までを行います

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

Project.Module1.ExportTablesToExcel

ステップ①の１１で追加するのは、上記のマクロ名のみです。

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

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

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

３．こちらの記事に記載したステップ②を行います

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

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

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

マクロの削除

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

マクロのコード

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

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

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

現在の公開バージョンは、V01L01（公開日：2024/9/23）です。

Sub ExportTablesToExcel()
'V01L01
    Dim wdDoc As Document
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim tbl As Table
    Dim tblCount As Integer
    Dim i As Integer, j As Integer, k As Integer, l As Integer
    Dim desktopPath As String
    Dim fileName As String
    Dim fileSuffix As Integer
    Dim sheetNames() As String
    Dim userResponse As VbMsgBoxResult
    Dim TotalCellCount As Integer
    Dim ExportedCellCount As Integer
    Dim NestedTableFlg As Boolean
    Dim inputBoxValue As Variant
    Dim OutputModeMessage As String
    Dim msgBoxValue As Integer
    Dim ModeFileName As String
    Dim docName As String
    Dim imgTop As Long
    Dim imgLeft As Long
    Dim StartPage As Long
    Dim EndPage As Long
    Dim pageRange As Range
    Dim rowStart As Long
    Dim rowEnd As Long
    Dim currentRow As Long
    Dim LoopCounter As Long
    Dim ColumnCounterForMode3 As Long

    Do
        '入力ボックスの表示
        inputBoxValue = InputBox _
        ("出力モードを数字（半角でも全角でも可）で入力してください" _
         & vbCrLf & vbCrLf & "1：標準モード" _
         & vbCrLf & vbCrLf & "2：テキストモード" _
         & vbCrLf & vbCrLf & "3：画像モード（★表が多いと時間がかかる場合あり★）" _
         & vbCrLf & vbCrLf & "4：テキスト＋オブジェクトモード" & vbCrLf, _
        "出力モード選択")
        
        'キャンセルの場合は終了
        If StrPtr(inputBoxValue) = 0 Then
            Exit Sub
        ElseIf inputBoxValue = "" Then
            MsgBox "数字を入力してください"
        ElseIf inputBoxValue <> "" Then
            Exit Do
        End If
    Loop
    
    If inputBoxValue <> 1 And inputBoxValue <> 2 And inputBoxValue <> 3 And inputBoxValue <> 4 Then
        MsgBox "無効な入力値です。1～4の整数を入力してください。", vbCritical, "エラー"
        Exit Sub
    End If
    
    Select Case inputBoxValue
        Case 1
            OutputModeMessage = "標準モードで処理を開始します" _
            & vbCrLf & "よろしいですか？"
        Case 2
            OutputModeMessage = "テキストモードで処理を開始します" _
            & vbCrLf & "よろしいですか？"
        Case 3
            OutputModeMessage = "画像モードで処理を開始します" _
            & vbCrLf & "よろしいですか？"
        Case 4
            OutputModeMessage = "テキスト＋オブジェクトモードで処理を開始します" _
            & vbCrLf & "よろしいですか？"
    End Select
    
    msgBoxValue = MsgBox(OutputModeMessage, vbYesNo + vbQuestion + vbDefaultButton2, "確認")

    If msgBoxValue = vbNo Then Exit Sub

    ' Wordドキュメントの取得
    Set wdDoc = ActiveDocument
    
    ' Wordドキュメントのファイル名を取得
    docName = ActiveDocument.Name

    tblCount = wdDoc.Tables.Count

    ' 表がない場合は処理を終了
    If tblCount = 0 Then
        MsgBox "このドキュメントには表がありません。"
        Exit Sub
    End If

    ' Excelアプリケーションの起動
On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
On Error GoTo 0

    xlApp.Visible = True ' Excel表示
    Set xlBook = xlApp.Workbooks.Add ' 新しいブックを追加
    
    ' 各表ごとにシートを作成し、テキストとオブジェクトをエクスポート
    For i = 1 To tblCount
' エラーハンドリング開始
On Error GoTo ErrorHandler
        
        Application.StatusBar = tblCount & "個の表中の" & i & "個目をエクセルファイルに出力中です..."

        Set tbl = wdDoc.Tables(i)
        TotalCellCount = tbl.Range.Cells.Count
        ExportedCellCount = 0

        ' 新しいシートを追加
        Set xlSheet = xlBook.Worksheets.Add
        xlSheet.Name = "表" & Format(i, "000")
        
        'モード1またはモード4
        If inputBoxValue = 1 Or inputBoxValue = 4 Then
            tbl.Range.Copy
            WaitSec (0.8)
            DoEvents
            xlSheet.Paste
            If inputBoxValue = 4 Then
                xlSheet.Cells.Clear
            End If
        End If
        
        'モード3
        If inputBoxValue = 3 Then

            Set tbl = wdDoc.Tables(i)
            StartPage = tbl.Cell(1, 1).Range.Information(wdActiveEndPageNumber)
            ColumnCounterForMode3 = tbl.Columns.Count

On Error GoTo 0

'最終行の最終列が結合行の一部である場合に備える
On Error Resume Next ' エラーを無視する
                    LoopCounter = 0
                    Do While True ' ループを開始
                        If LoopCounter > 100 Then
                            Exit Do
                        End If
                        EndPage = tbl.Cell(tbl.Rows.Count, ColumnCounterForMode3).Range.Information(wdActiveEndPageNumber)
                        If Err.Number = 5941 Then
                            ' エラー5941の場合、列1つ分戻る
                            ColumnCounterForMode3 = ColumnCounterForMode3 - 1
                            Err.Clear ' エラーをクリア
                        Else
                            ' エラーがない場合、ループを終了
                            Exit Do
                        End If
                        LoopCounter = LoopCounter + 1
                    Loop
On Error GoTo 0
On Error GoTo ErrorHandler
           
            ' 開始位置設定
            imgTop = 10
            imgLeft = 10
            
           ' 表の複数ページの範囲を処理
            For l = StartPage To EndPage
                ' 各ページの範囲を取得
                If l = StartPage Then
                    ' 1ページ目の範囲
                    rowStart = tbl.Range.Start
                    ' 1ページ目に表が収まっている場合
                    If EndPage = StartPage Then
                        rowEnd = tbl.Range.End ' 表が1ページに収まっている場合
                    Else
                        rowEnd = wdDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=l + 1).Start - 1 ' 次のページの開始前までの範囲
                    End If
                ElseIf l = EndPage Then ' 最後のページの場合
                    rowStart = wdDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=l).Start ' 現在のページの開始位置
                    rowEnd = tbl.Range.End ' テーブルの終了位置
                Else ' 中間ページの場合
                    rowStart = wdDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=l).Start ' 現在のページの開始位置
                    rowEnd = wdDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=l + 1).Start - 1 ' 次のページの開始前までの範囲
                End If
        
                ' ページの範囲を選択
                Set pageRange = wdDoc.Range(Start:=rowStart, End:=rowEnd)
        
                ' 範囲をコピー
                pageRange.Copy
                
                Application.StatusBar = tblCount & "個の表中の" & i & "個目をエクセルファイルに出力中です..."
                        
                ' Excelに画像として貼り付け
                WaitSec (0.8)
                xlSheet.PasteSpecial
                
                ' 画像の位置調整
                With xlSheet.Shapes(xlSheet.Shapes.Count)
                    .Top = imgTop
                    .Left = imgLeft
                    imgTop = imgTop + .Height + 10 ' 画像の下にスペースを追加して次の画像を挿入
                End With
            Next l

        End If
        
        'モード2または4
        If inputBoxValue = 2 Or inputBoxValue = 4 Then
        
            ' 表の各セルのテキストデータをExcelにコピー
            For j = 1 To tbl.Rows.Count
                For k = 1 To tbl.Columns.Count
                    
                    Dim cellContent As String
                    Dim objShape As Shape
                    Dim objInlineShape As inlineShape
                                                   
On Error GoTo 0
On Error Resume Next ' エラーを無視する
                    LoopCounter = 0
                    Do While True ' ループを開始
                        If LoopCounter > 100 Then
                            Exit Do
                        End If
                        cellContent = cellContent & tbl.Cell(j, k).Range.Text
                        If Err.Number = 5941 Then
                            ' エラー5941の場合、kをインクリメント
                            k = k + 1
                            Err.Clear ' エラーをクリア
                        Else
                            ' エラーがない場合、ループを終了
                            Exit Do
                        End If
                        LoopCounter = LoopCounter + 1
                    Loop
On Error GoTo 0
On Error GoTo ErrorHandler

                    ' テキストを取得
                    cellContent = ""
                    cellContent = cellContent & tbl.Cell(j, k).Range.Text
                    
                    ' 不要な文字を削除
                    cellContent = Replace(cellContent, vbCr, vbLf)
                    If Right(cellContent, 1) = Chr(7) Then
                        cellContent = Left(cellContent, Len(cellContent) - 2)
                    End If
                    cellContent = Replace(cellContent, Chr(7), "")
                    
                    ' オブジェクトの位置を特定し、その部分を削除
                    Dim objPos As Integer
                    objPos = InStr(cellContent, Chr(1))
                    While objPos > 0
                        cellContent = Left(cellContent, objPos - 1) & Mid(cellContent, objPos + 1)
                        objPos = InStr(cellContent, Chr(1))
                    Wend
                    
                    Application.StatusBar = tblCount & "個の表中の" & i & _
                    "個目の" & j & "行" & k & "列目をエクセルファイルに出力中です..."
                    
                    DoEvents
                    
                    xlSheet.Cells(j, k).Value = cellContent
                    
                    ExportedCellCount = ExportedCellCount + 1
                    
                    If ExportedCellCount = TotalCellCount Then
                        Exit For
                    End If
                    If tbl.Cell(j, k).Next.RowIndex > j Then
                        Exit For
                    End If
                Next k
            Next j
        End If
    Next i
' エラーハンドリングを終了
On Error GoTo 0

    ' "Sheet1" シートがあれば削除
On Error Resume Next
    Set xlSheet = xlBook.Worksheets("Sheet1")
    If Not xlSheet Is Nothing Then
        xlSheet.Delete
    End If
On Error GoTo 0

    ' 処理状況をステータスバーに表示
    Application.StatusBar = "エクセルシートをソートしています"

    ' シート名を取得してソート
    Dim sheetCount As Integer
    sheetCount = xlBook.Worksheets.Count
    ReDim sheetNames(1 To sheetCount)

    For i = 1 To sheetCount
        sheetNames(i) = xlBook.Worksheets(i).Name
    Next i

    ' シート名を昇順にソート
    For i = 1 To sheetCount - 1
        For j = i + 1 To sheetCount
            If sheetNames(i) > sheetNames(j) Then
                Dim temp As String
                temp = sheetNames(i)
                sheetNames(i) = sheetNames(j)
                sheetNames(j) = temp
            End If
        Next j
    Next i

    ' ソートされた順にシートを並び替え
    For i = 1 To sheetCount
        xlBook.Worksheets(sheetNames(i)).Move After:=xlBook.Worksheets(xlBook.Worksheets.Count)
    Next i

    ' 最初のシートをアクティブにする
    xlBook.Worksheets(1).Activate

    Application.StatusBar = "エクセルファイルを保存する準備をしています"
    
    ' デスクトップのパスを取得
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")

    Select Case inputBoxValue
        Case 1
            ModeFileName = "標準モード"
        Case 2
            ModeFileName = "テキストモード"
        Case 3
            ModeFileName = "画像モード"
        Case 4
            ModeFileName = "テキスト＋オブジェクトモード"
    End Select

    ' ファイル名の重複を避けるために連番を付ける
    fileSuffix = 1
    Do While Dir(desktopPath & "\" & fileName) <> ""
        fileName = docName & "からの出力_" & ModeFileName & "_" & fileSuffix & ".xlsx"
        fileSuffix = fileSuffix + 1
    Loop

    Application.StatusBar = "エクセルファイルを保存しています"

    ' デスクトップにExcelファイルを保存
    xlBook.SaveAs fileName:=desktopPath & "\" & fileName

    Application.StatusBar = "メモリを解放しています"
    
    ' オブジェクトの解放
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Set wdDoc = Nothing
    
    Application.StatusBar = "処理が終了しました"
    
    ' メモリをクリア
    ClearClipboard

    MsgBox tblCount & "個の表をエクセルファイルに出力しました" _
    & vbCrLf & "（このエクセルファイルはデスクトップに保存されています）", vbSystemModal
    Exit Sub

ErrorHandler:
    If Err.Number = 1004 Then
        WaitSec (1)
        xlSheet.PasteSpecial
    Else
        MsgBox "エラーが発生しました。処理を継続します。" & vbCrLf & "エラー番号: " & Err.Number & vbCrLf & "説明: " & Err.Description
    End If
    Resume Next
End Sub

Sub WaitSec(WaitTime As Integer)
    Dim endTime As Double
    endTime = Timer + WaitTime
    Do While Timer < endTime
        DoEvents
    Loop
End Sub

Sub ClearClipboard()
    ' クリップボードをクリア
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText ""
        .PutInClipboard
    End With
End Sub