マクロの概要
このマクロは、ワード文書中のすべての表を自動で抽出し、各シートに１つの表を含むエクセルファイルとしてデスクトップ上に出力（エクスポート）するワードマクロ（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