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 ' *----*----* *----*----* *----*----*