Sub myDocInsertTable()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem Word文書ファイルの挿入・表作成処理
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Word VBA
  Rem 機能...
  Rem   複数のWord文書ファイルを挿入し、
  Rem   本文の文字列を表に変換する。
  Rem 注記...
  Rem   1列目にファイル名を追加。
  Rem   2列目以降にWord文書ファイルの本文を挿入。
  Rem   本文の改行をタブに置換し、
  Rem   文字列の区切りをタブとして、文字列を表に変換する。
  Rem 履歴...
  Rem   第1版:2005/04/16:作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myDlgPick As FileDialog
  Dim mySelectedItem As Variant
  Dim myGetFileName As String
  Dim myWord As Word.Application
  Rem 前処理
  If Documents.Count >= 2 Then
    MsgBox "文書を閉じて下さい。"
    Exit Sub
  End If
  If Documents.Count = 1 Then
    If ActiveDocument.Characters.Count > 1 Then
      MsgBox "文書を閉じて下さい。"
      Exit Sub
    Else
      If ActiveDocument.Words(1).Text <> vbCr Then
        MsgBox "文書を閉じて下さい。"
        Exit Sub
      Else
        ActiveDocument.Close
      End If
    End If
  End If
  Rem ファイルの指定
  Set myDlgPick = Application.FileDialog(msoFileDialogFilePicker)
  With myDlgPick
    .AllowMultiSelect = True
    .Filters.Add "Word文書", "*.doc", 1
    If .Show = 0 Then
      Rem [キャンセル]ボタンを押した場合
      Set myDlgPick = Nothing
      Application.Documents.Add
      Exit Sub
    End If
  End With
  Rem ファイルごとの処理
  Set myWord = GetObject(, "Word.Application")
  Application.Documents.Add
  For Each mySelectedItem In myDlgPick.SelectedItems
    With Selection
      .HomeKey unit:=wdStory, Extend:=wdMove
      myGetFileName = Mid(mySelectedItem, InStrRev(mySelectedItem, "\") + 1)
      .TypeText (myGetFileName & vbTab)
      .InsertFile FileName:=mySelectedItem, Range:="", ConfirmConversions:=False, _
        Link:=False, Attachment:=False
      .Collapse (wdCollapseEnd)
    End With
    '
    Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdMove
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = vbCr
      .Replacement.Text = vbTab
      .Forward = False
      .Wrap = wdFindStop
      .Format = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .MatchFuzzy = True
      Do
        .Execute Replace:=wdReplaceOne
        If Not .Found Then Exit Do
      Loop
    End With
  Next mySelectedItem
  Rem 文書末尾の改行を削る。
  With Selection
    .EndKey unit:=wdStory, Extend:=wdMove
    .TypeBackspace
  End With
  Selection.WholeStory ' すべて選択
  Rem 文字列を表にする。
  Selection.ConvertToTable Separator:=wdSeparateByTabs, _
  AutoFitBehavior:=wdAutoFitContent
  With Selection.Tables(1)
    .Style = "表 (格子)"
    .ApplyStyleHeadingRows = True
    .ApplyStyleLastRow = True
    .ApplyStyleFirstColumn = True
    .ApplyStyleLastColumn = True
  End With
  Selection.Collapse wdCollapseEnd
  Rem 処理の終了
  Set myDlgPick = Nothing
  Set myWord = Nothing
End Sub ' myDocInsertTable ' *----*----*    *----*----*    *----*----*
inserted by FC2 system