Sub myTableInsertAfter()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 複数文書ファイル内同一書式表セル末尾挿入統合処理
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Word VBA
  Rem 機能...
  Rem   開いている複数の文書ファイルにある同一書式の表を、
  Rem   各々のセルの値を、セルの値の末尾に挿入していき、
  Rem   新規文書に1つに纏めた表を作る。
  Rem 注記...
  Rem   文書ファイルは2つ以上であること。
  Rem   文書内に同一書式の表があること。
  Rem   第1行・第1列をタイトル行列とする。
  Rem 履歴...
  Rem   第1版：2005/05/09：作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim i As Integer
  Dim r As Long
  Dim c As Long
  Dim myTable As Table
  Dim myMax As Long
  Dim myCur As Long
  Dim myRatio As Integer
  Dim myText As String
  Dim myStatusBar As String
  '
  If Documents.Count < 2 Then
    Exit Sub
  End If
  myCur = 0
  '
  Rem 最初に開いた文書ファイルの表をコピーする。
  Documents(Documents.Count).Tables(1).Range.Copy
  '
  Rem 新規文書を追加し、表を貼り付ける。
  Documents.Add
  Selection.TypeParagraph
  Selection.Range.Paste
  Set myTable = Documents(1).Tables(1)
  myMax = myTable.Rows.Count * myTable.Columns.Count * (Documents.Count - 1)
  '
  Application.ScreenUpdating = False
  For i = (Documents.Count - 0) To 2 Step -1
    For r = 1 To myTable.Range.Rows.Count
      For c = 1 To myTable.Range.Columns.Count
        If r <> 1 And c <> 1 Then ' タイトル行列は処理しない。
          Rem セルに値を入れる。
          If i = Documents.Count Then
            Rem 最初に開いた文書ファイルの文書名を挿入する。
            myText = Documents(i).Tables(1).Cell(r, c).Range.Text
            myText = Left(myText, Len(myText) - 1) ' 改行を削除。
            myText = Documents(i).Name & vbVerticalTab & myText
            myTable.Cell(r, c).Range.Text = myText
            myTable.Cell(r, c).Range.Select ' セルの選択。
            Selection.EndKey Unit:=wdLine, Extend:=wdMove ' セルの末尾カーソルを移動させる。
            Selection.TypeBackspace ' バックスペース（余分な改行を削除）。
          Else
            Rem 次以降に開いた文書ファイルの文書名とセルの値を挿入する。
            myText = Documents(i).Tables(1).Cell(r, c).Range.Text
            myText = Left(myText, Len(myText) - 1) ' 改行を削除。
            myText = Documents(i).Name & vbVerticalTab & myText
            myTable.Cell(r, c).Range.InsertAfter Text:=vbCr & myText
            myTable.Cell(r, c).Range.Select ' セルの選択。
            Selection.EndKey Unit:=wdLine, Extend:=wdMove ' セルの末尾カーソルを移動させる。
            Selection.TypeBackspace ' バックスペース（余分な改行を削除）。
          End If
        End If
        Rem ステータスバー表示
        myCur = myCur + 1
        myRatio = Int(myCur * 100 / myMax)
        myStatusBar = Format(myRatio, "###") & "%"
        Application.StatusBar = "myTableInsertAfter 処理中：" & myStatusBar
      Next c
    Next r
  Next i
  '
  Rem タイトル行列の文字列を中央揃えにする。
  With myTable.Columns(1)
    .Select
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
  '
  With myTable.Rows(1)
    .Select
  End With
  Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
  '
  Application.ScreenUpdating = True
  Rem 新規文書の先頭にカーソルを移動させる。
  Selection.HomeKey Unit:=wdStory, Extend:=wdMove
  Application.StatusBar = "myTableInsertAfter 処理完了！"
End Sub ' myTableInsertAfter *----*----*    *----*----*    *----*----*    *----*----*