最近クライアントとの会話の中で、数百ページのファイル中にある表だけを確認できたらいいなと話になりました。
とりあえず作ってみました。表だけが数十も列挙されるとけっこう大変ですね。どう活用するのかはお任せします（笑）。
このマクロでできること
実行前
以下のようにいくつか表が書かれているファイルがあります。このファイルを開いてマクロを実行します。
実行後
新規ファイルに表が書き出されます。表の直前にTable 1やTable 2 などの表番号を挿入します。
文書の冒頭に目次が表示されます。
［表示］タブの［ナビゲーションウィンドウ］をオンにすれば、見出しマップが表示されます。ここから対象とする表にジャンプできます。
マクロの解説
現在文書中の表を、新規文書に書き出しています。
このときにクリップボードを用いたコピペを行うとエラーになることがあるので、FormattedText プロパティを使っています（32行目）。
新規文書の末尾に加えていく感じです。
24行目や31行目にて、文書の末尾をRangeオブジェクトに設定しています。このマクロでは、Bookmarks オブジェクトを用いて指定しています。
表番号にはスタイルを設定しています（28行目）。見出しスタイルを段落に設定すれば、目次の自動作成が可能ですし、ナビゲーションウィンドウの見出しマップにも項目が表示されるので便利です。
マクロ
Sub 文書中の表を書き出す()
Dim myTable As Table
Dim i As Integer
Dim myRange As Range
Dim myDocFrom As Document '元のファイル
Dim myDocTo As Document '書出し用ファイル
'-------------------------------------------
'前処理
'-------------------------------------------
Set myDocFrom = ActiveDocument
Set myDocTo = Documents.Add
i = 0
'-------------------------------------------
'表を書き出す
'-------------------------------------------
For Each myTable In myDocFrom.Tables
'文書の末尾に表番号を挿入
i = i + 1
Set myRange = myDocTo.Bookmarks("\EndOfDoc").Range
myRange.Text = "Table " & i & vbCr
'表番号にスタイルを設定
myRange.Paragraphs(1).Style = myDocTo.Styles(wdStyleHeading1)
'文書の末尾に表を挿入
Set myRange = myDocTo.Bookmarks("\EndOfDoc").Range
myRange.FormattedText = myTable.Range.FormattedText
Next
'-------------------------------------------
'目次を挿入する
'-------------------------------------------
Set myRange = myDocTo.Range(0, 0)
myRange.Fields.Add Range:=myRange, _
Type:=wdFieldEmpty, _
Text:="TOC ", _
PreserveFormatting:=True
myRange.InsertParagraphAfter
'-------------------------------------------
'後処理
'-------------------------------------------
Set myDocFrom = Nothing
Set myDocTo = Nothing
End Sub
