【Word VBA】複数のWord文書を結合し、表があれば新規Wordファイルに出力する

はじめまして。
このブログではこれまで学習してきたVBAやその他プログラミング関係のこと、自分の備忘録などを書いていこうと思います。
どうぞ宜しくお願いします！

※初めての方でも分かるように、説明が冗長な部分が多々ありますが、どうぞご了承いただけると幸いです。
※ディレクトリの区切りを表現する円記号は \ に置き換わってます。
※環境はWindows10Pro　Office365　です。

さぁ、いってみよう！
今回、複数のファイルを１つにまとめるための大きな枠組み、仕組みづくりに参考にさせて頂いたサイトはこちらです。
since2016note.at.webry.info
www.wordvbalab.com

1.変数の宣言と初期化処理

 Sub 複数ファイルを新規ドキュメントに結合_表を別ファイルに取り出す()
    Dim fld                 As FileDialog
    Dim myFolderPath        As String        'Wordファイルのパス
    Dim strParentFileName   As String        'Wordファイル名
    Dim mySecNum            As Long          'セクション番号
    Dim sec                 As Section       'セクション（ヘッダー削除時に使用）
    Dim isp                 As InlineShape   'ドキュメント内の図形（画像）
    Dim hdr                 As HeaderFooter  'HeaderFooterはヘッダーまたはフッターを表す
    Dim myNewTable          As Table         '解答一覧を格納
    
    '解答一覧作成に使用
    Dim iTenkisakiRetuCnt1  As Long          '1つ目の表の転記先列カウンタ
    Dim iTenkisakiRetuCnt2  As Long          '2つ目以降の表を転記するための列移動カウンタ
    Dim myTableColumns      As Long          '新たに作成する表の列数
    Dim myTableRows         As Long          '新たに作成する表の行数
    Dim moveRetuPos         As Long          '元表の列数
    Dim intTableIndex       As Long
    Dim myDoc               As Document
    Dim myParentTable       As Table
    Dim iRowsCnt            As Long
    Dim iColumnsCnt         As Long
    Dim myText              As String
    Const iLineSpacingValue As Long = 20     '行間の固定値を定数指定
    Const iRetuKaishiPosY   As Long = 1      '表の転記先開始列番号

    Dim myUnneededTable     As Table         '表を集約後に削除する個々の表
    Dim strMyFileName       As String        'ファイル保存時のファイル名

    '表のフォントサイズとフォント名を定数化
    Const iTableFontSize    As Single = 9.5
    Const strFontName       As String = "ＭＳ ゴシック"
    Const iTableRowsHight   As Long = 13
        
    '初期化処理
    iTenkisakiRetuCnt1 = 0
    iTenkisakiRetuCnt2 = 0
    

2.フォルダ選択ダイアログ表示_選択したフォルダパスとファイル名を取得

    'フォルダ選択ダイアログを表示
    Set fld = Application.FileDialog(msoFileDialogFolderPicker)
    
    If fld.Show = 0 Then Exit Sub
        myFolderPath = fld.SelectedItems(1)
        strParentFileName = Dir(myFolderPath & "\*.docx*")   '*<<1>>*
        
        '★ちょっと確認★
        'ファイルダイアログで選択したフォルダパスをイミディエイトウインドウに表示
        Debug.Print "取得した myFolderPathは　　" & myFolderPath & "　　です。"
        
        'ファイルダイアログで選択したフォルダに存在するファイルの最初のファイル名をイミディエイトウインドウに表示
        Debug.Print "取得した myFileNameは　　" & strParentFileName & "　　です。"

        '画面のちらつきを防止するために画面更新停止
        Application.ScreenUpdating = False

⇒ 【 Dir 関数とは 】
　 ・パターンと属性が一致する最初のファイルやフォルダを取得。
　 ・今回属性は省略。属性を省略すると標準ファイルが指定される。
　 ・ワイルドカード[? や *]を使用して複数のファイルが一致するときは、最初のファイルを返す。
・ \*.docx* の意味
次の２つを組み合わせることでファイル名のみを取得することが出来る
[1] \* ⇒ \記号を含む任意の文字列を指定
[2] .docx* ⇒ .docx を含む任意の文字列を指定
　・ 引用元サイトTipsfound 様のサイトより一部引用(閲覧日時2019.09.14)
www.tipsfound.com

3.選択したフォルダ内にWordファイルが無ければプロシージャを終了する。Wordファイルが存在する場合は新規Wordファイルを作成

    If strParentFileName = "" Then MsgBox "選択したフォルダ内に、Wordファイルがありません。": Exit Sub

    ' 複数のWordファイルを１つに集約するための新規ドキュメントを作成し、ドキュメント末尾に追記
    '新規ドキュメント作成
    Documents.Add

'⇒ 【 Documents.Add とは 】 _
・新規のWordファイルを開くメソッド _
・既存のWordドキュメントを開くには Documents.Open メソッドを使用する _
・引用元サイトMyRecord 様のサイトより一部引用(閲覧日時2019.09.14) _
kosapi.com

4.選択したフォルダ内の全ドキュメントをコピーし、新規作成したWordドキュメントに貼り付ける。全ファイルを取得、処理するファイルが無くなったら終了

    Do While strParentFileName <> ""
        
        '処理中のファイル名をイミディエイトウインドウに表示
        Debug.Print "処理中のファイルは  " & strParentFileName & "  です。"
        
        With Selection       
            '取得したファイルの内容を入力するセクション番号（≒入力を開始するカーソル位置）を取得 _
             (現在のカーソル位置がドキュメント内の何番目のセクションにあるかを取得し、変数 mySecNum に格納)
            mySecNum = ActiveDocument.Range(0, Selection.Sections(1).Range.End).Sections.Count
                        
            'ファイルの内容をドキュメント末尾に追記
            .InsertFile fileName:=myFolderPath & "\" & strParentFileName
            
            'カーソル位置を選択（改行記号が選択される）
            .InsertParagraphAfter
            
            '読み込むファイルごとにセクション区切りを入れる場合はコメントブロックを解除 _
             選択部分の直前に現在の位置から開始するセクション区切りを挿入
            .InsertBreak Type:=wdSectionBreakContinuous
        End With
        
        strParentFileName = Dir()
        ' ⇒ Dir() によって次のファイルを取得 _
         *<<1>>* にてDir関数を使用してファイル名を取得後、引数を省略してDir関数を呼び出すと、 _
         その次のファイルを取得できる
    Loop
    

'⇒ 【 Selection について知りたい方は 】 _
参考Webサイト「いつも隣にITのお仕事」より _
『 Word VBAでカーソル位置に文字を入力するとっても簡単なプログラム ～ Selectionオブジェクトとは ～ 』
tonari-it.com

5. 1つにまとめた文書のページ設定を行う

    '文書の各セクションに対して余白を設定 _
     １セクションずつ余白を設定しないとうまく余白設定できない場合があります。
    For Each sec In ActiveDocument.Sections
        sec.PageSetup.LinesPage = 25                                '文書のグリッドの1ページあたりの行数
        sec.PageSetup.LineNumbering.Active = False                  '行番号を非表示設定
        sec.PageSetup.TopMargin = MillimetersToPoints(12.7)         '上余白
        sec.PageSetup.BottomMargin = MillimetersToPoints(12.7)      '下余白
        sec.PageSetup.LeftMargin = MillimetersToPoints(12.7)        '左余白
        sec.PageSetup.RightMargin = MillimetersToPoints(12.7)       '右余白
        sec.PageSetup.Gutter = MillimetersToPoints(0)               'とじしろ
        sec.PageSetup.HeaderDistance = MillimetersToPoints(10)      '用紙の端からの距離(ヘッダー)
        sec.PageSetup.FooterDistance = MillimetersToPoints(10)      '用紙の端からの距離(フッター)
    Next sec

    '行間設定 _
     ドキュメント全体に対して設定 _
     行間の幅（LineSpacingRule）を固定値（wdLineSpaceExactly）に設定 _
     行間に設定する値を数値設定
    With ActiveDocument.Paragraphs
        .LineSpacingRule = wdLineSpaceExactly
        .LineSpacing = iLineSpacingValue      '行間の設定値に定数（iLineSpacingValue）を使用
    End With

>|vb|
'⇒ 【 行間設定について 】 _
参考サイト _
We-vba WordやExcelでVBA（マクロ）を有効に活用しましょう！
we-vba.info
|

    '文書内の図形（画像）の行間を設定
    'ドキュメント内に図形が含まれている場合は _
     図形(画像)の行間を<b>1行</b>に変更（画像が隠れてしまうのを防止） _
     文字列のみで画像が含まれていなければ以下7行不要かと思います。

    For Each isp In ActiveDocument.InlineShapes
        With isp
            With .Range
                 .Paragraphs.LineSpacingRule = wdLineSpaceSingle
            End With
        End With
    Next isp
    
    'ヘッダーを削除
    'ヘッダーを残す場合は以下5行をコメントブロックまたは削除してください
    For Each sec In ActiveDocument.Sections
        For Each hdr In sec.Headers
            hdr.Range.Delete
        Next
    Next sec

'【 ヘッダーとフッターの設定について 】 _
参考サイト _
インストラクターのネタ帳より　ヘッダー・フッターを削除するWordマクロ
www.relief.jp

6. 文書内に表が存在しない場合と存在する場合で処理を分岐

表が存在しない場合：セクション区切りを削除し、ファイルを保存
表が存在する場合：表と文書を分離

    ' -------------------
    '  表が存在しない場合
    ' -------------------
    '文書（ActiveDocument）内の表の数（Tables.Count ）が０なら表は存在しない。
    If ActiveDocument.Tables.Count = 0 Then

        'ドキュメントをインデックス番号で直接指定してセクション区切りを削除
        Documents(1).Activate
        With Selection.Find
            .ClearFormatting
            .ClearFormatting
            .Text = "^b"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .MatchFuzzy = False
            .Execute Replace:=wdReplaceAll
        End With
    
        'ファイルをdocx形式ファイルとして保存
        ActiveDocument.SaveAs2 fileName:=myFolderPath, FileFormat:=wdFormatDocumentDefault
        Debug.Print "ファイル結合保存完了"
    
    Else
        ' -----------------
        '  表が存在する場合
        ' -----------------
         '文書末尾に転記用の表として列数と行数を指定して作成。 _
         '列数と行数をInputBox関数を使ってユーザーから取得 _
         '初期値を Default:= 以降に指定。 _
         '列数未指定の場合：初期値として、元となる表の列数に表の数を掛けた列数を返す（1つの表の列が4列、票の数が4つの場合は４×４＝１６列の表を作成） _
         '行数未指定の場合：初期値として転記元の1番目の表の行数を指定 _
         'さらに、転記元の表の列数を取得（2つ目以降の表データ転記時の1番目のセルの列番号に使用） _
         '本来、ここの処理はフォームを使用し、値をまとめて取得すると分かりやすいと思います。今後の課題です。。
        
        MsgBox "転記元の表から転記する列数および、新しく作成する表の列数と行数を指定します。"
        myTableColumns = VBA.Interaction.InputBox("新しく作成する表の列数を入力してください。", Default:=ActiveDocument.Tables.Item(1).Columns.Count * ActiveDocument.Tables.Count)
        myTableRows = VBA.Interaction.InputBox("新しく作成する表の行数を入力してください。", Default:=ActiveDocument.Tables.Item(1).Rows.Count)
        moveRetuPos = VBA.Interaction.InputBox("転記元の表の列数を入力してください。", Default:=ActiveDocument.Tables.Item(1).Columns.Count)

'【 WordVBA におけるInputBox関数について 】 _
参考サイト _
インストラクターのネタ帳より　InputBox関数とAppication.InputBoxメソッドはまったくの別物ですよ _
www.relief.jp

7. 1つにまとめたファイルの末尾に表を作成し、表のみを転記する

        '新規ドキュメントを作成し、表のみを貼り付けるための「 空の表 」を作成 _
         新しい表の列数、行数、元の表の列数にInputBoxより取得した値を指定
        Set myNewTable = ActiveDocument.Tables.Add( _
            Range:=Selection.Range, _
            NumRows:=myTableRows, _
            NumColumns:=myTableColumns _
            )
            
        '表罫線を設定（設定しない場合は罫線無し）
        myNewTable.Style = "表 (格子)"
                        
        Debug.Print "転記用の表作成完了！"

参考サイト _
インストラクターのネタ帳より　表を作成・挿入するWordマクロ _
www.relief.jp

        'オブジェクト変数を初期化
        Set myNewTable = Nothing
        
        ' **************
        ' 表転記処理開始
        ' **************
        '転記する表の数は転記用の表を除くので、全ての表の数から１を引いた数となります
        For intTableIndex = 1 To ActiveDocument.Tables.Count - 1
    
            '------
            '前処理
            '------
            'ActiveDocumentをオブジェクト変数（myDoc）に格納
            Set myDoc = ActiveDocument
            If myDoc.Tables.Count > 0 Then
                'コピー元の（myDoc.Tables）表をインデックス番号（intTableIndex）で指定し、オブジェクト変数であるコピー元の表（myParentTable）に格納
                Set myParentTable = myDoc.Tables(intTableIndex)
            Else
                '表が存在しない場合はプロシージャを終了する
                Exit Sub
            End If
            
            '----------------------------
            '文字列の取得と転記
            '----------------------------
            For iRowsCnt = 1 To myParentTable.Rows.Count
        
                ' ** 元となる表から文字列を取得 **
                For iColumnsCnt = 1 To moveRetuPos
                
                'もしここで、規則的に離れた列番号を取得する場合はStepを指定することで実装可能。 _
                '1列目と3列目の文字列を取得する場合なら、
                'For iColumnsCnt = 1 To 3 Step 2　としてやればコピー元から1列目と3列目の文字列を取得することができる。
                 '不規則に列を取得したい 1列目、2列目、5列目、7列目、9列目、10列目などの場合は、フォームのチェックボックスを使用し、列番号を取得すればできそうだが、知識と技術が及ばず、今回は保留。。。。。
                   '取得する文字列を変数（myText）に格納
                    '列番号を　iColumnsCnt + 1 - 1　と記述した理由 ↓
                    '列カウンタが１から始まるため、もし列カウンタに１を足すだけだと
                    'iColumnsCnt＝1 の時 1+1＝2　となり1列目を指定できなくなります。

                    'WordVBAでの表のセルへのアクセス方法
                    'Excelの場合だとWorksheet(”Sheet1”).Cells(行番号,列番号).Value のようにすればセルのデータにアクセスできるのですが、Wordの表（セル）へのアクセスは異なり、これを見つけるまでかなり悶絶しました。
                    'ActiveDocument.Tables(インデックス番号).Cell(行番号, 列番号).Range.Text 
                    '今回は「ActiveDocument.」の部分は元の表という意味からオブジェクト変数「myParentTable」としています。
                  '先にも書きましたが、myParentTable　の中身「myDoc.Tables(intTableIndex)」はドキュメントの表（Tables）をインデックス番号（intTableIndex）で指定しています　

                    myText = myParentTable.Cell(iRowsCnt, iColumnsCnt + 1 - 1).Range.Text
                
                    ' ★------>
                    myText = Left(myText, Len(myText) - 1)  '<*****>

                    myText = Replace(myText, vbCr, " ")

                    myText = Replace(myText, " ", "")
                    ' <------★

                    ' ** 値(myText)の入力 **
                 '  iRetuKaishiPosY　：転記先の入力開始列。1列目を定数として指定

                    ActiveDocument.Tables(myDoc.Tables.Count).Cell(iRowsCnt, iRetuKaishiPosY + iTenkisakiRetuCnt1 + iTenkisakiRetuCnt2).Range.Text = myText

                    iTenkisakiRetuCnt1 = iTenkisakiRetuCnt1 + 1

                Next iColumnsCnt
            
                '上記 ★------> から　<------★ までの処理の意味については、 _
                    このコード作成時に参考にした次のページがとても分かりやすいです。 _
                    ワードの表に含まれる改行記号は通常のものと扱いが異なるため注意が必要との事です。 _
                    ' _
                    'みんなのワードマクロ _
                    '「【コード】Wordの表をExcelにコピペするWordマクロ」より _
                    '  [https://www.wordvbalab.com/code/7912/ :embed:cite]

                    'なお、参考にした「みんなのワードマクロ」には <*****> の次の行に _
                    'myText = Replace(myText, vbCr, vbLf というコードがありますが、 _
                    'ワードからワードへの表転記の場合は改行記号が残ってしまうようで削除しています。 _
                    'これに伴って削除する改行記号が1つ分減少するため、 _
                    '参考にしたコードでは末尾が -2 となっているのを -1 としています。 _
                    '  -2  のままだと、必要な文字列が1文字削除されてしまいます。
     
                '列カウンタを初期化
                iTenkisakiRetuCnt1 = 0

            Next iRowsCnt
     
            '------
            '後処理
            '------
            'オブジェクト変数の解放
            Set myDoc = Nothing
            Set myParentTable = Nothing
            iRowsCnt = 0
            iColumnsCnt = 0
                
            '2つ目以降の表の転記先（列）を指定 _
             転記先の未入力列を指定するために、転記した列数分（moveRetuPos）ずらす。
            iTenkisakiRetuCnt2 = iTenkisakiRetuCnt2 + moveRetuPos
            
        Next intTableIndex

        Debug.Print "表の転記終了"

8. 文書末尾に作成した表のみをコピーして新規ドキュメントに貼り付け

        '文書末尾に１つにまとめた表を選択、コピー
        ActiveDocument.Tables(ActiveDocument.Tables.Count).Select
        ActiveDocument.Tables(ActiveDocument.Tables.Count).Range.Copy
        
        '新規ドキュメントを開き、コピーした一覧を貼り付け
        Documents.Add
        Selection.Paste

9. 解答一覧ファイルのページ設定

        '余白設定
        For Each sec In ActiveDocument.Sections
            sec.PageSetup.LinesPage = 25                                '文書のグリッドの1ページあたりの行数
            sec.PageSetup.LineNumbering.Active = False
            sec.PageSetup.TopMargin = MillimetersToPoints(12.7)         '上余白
            sec.PageSetup.BottomMargin = MillimetersToPoints(12.7)      '下余白
            sec.PageSetup.LeftMargin = MillimetersToPoints(12.7)        '左余白
            sec.PageSetup.RightMargin = MillimetersToPoints(12.7)       '右余白
            sec.PageSetup.Gutter = MillimetersToPoints(0)               'とじしろ
            sec.PageSetup.HeaderDistance = MillimetersToPoints(10)      '用紙の端からの距離(ヘッダー)
            sec.PageSetup.FooterDistance = MillimetersToPoints(10)      '用紙の端からの距離(フッダー)
        Next sec

        '行間設定
        With ActiveDocument.Paragraphs
            .LineSpacingRule = wdLineSpaceExactly
            .LineSpacing = 13
        End With
    
        '図の行間のみ1行に設定
        For Each isp In ActiveDocument.InlineShapes
            With isp
                With .Range
                    .Paragraphs.LineSpacingRule = wdLineSpaceSingle
                End With
            End With
        Next isp
    
        'ヘッダー削除
        For Each sec In ActiveDocument.Sections
            For Each hdr In sec.Headers
                hdr.Range.Delete
            Next hdr
        Next sec

        '表の各種設定[フォントサイズ・フォント名・列幅]
        With ActiveDocument.Tables(1)
            .Range.Font.Size = iTableFontSize
            .Range.Font.Name = strFontName
            .AutoFitBehavior (wdAutoFitContent)
            .Rows.Height = iTableRowsHight
        End With
    
        '表のコピーペーストが終了したので1つに集約したファイル中の表を削除
        For Each myUnneededTable In Documents(2).Tables
            myUnneededTable.Delete
        Next myUnneededTable

'【 ファイルの保存について 】 _
インストラクターのネタ帳 _
選択文字列をファイル名にして名前を付けて保存ダイアログを表示するWordマクロ より _
www.relief.jp

       'InputBox関数を使用しユーザーからファイル名を取得。
        strMyFileName = VBA.Interaction.InputBox("分離した表のファイル名を入力してください。", Default:=Format(Date, "yyyy年mm月dd日"))
      
       'InputBoxより取得したファイル名を入力した状態で､名前を付けて保存ダイアログを表示
        With Application.FileDialog(msoFileDialogSaveAs)
            .InitialFileName = strMyFileName    'ファイル名の設定
            If .Show = False Then
                Exit Sub  'キャンセル
            Else
                .Execute  '保存
            End If
        End With
        
        'インプットボックスで取得した文字列を初期化
        strMyFileName = ""
           
        'ドキュメントをインデックス番号で直接指定してセクション区切り削除
        Documents(2).Activate    
        With Selection.Find
            .ClearFormatting
            .ClearFormatting
            .Text = "^b"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .MatchFuzzy = False
            .Execute Replace:=wdReplaceAll
        End With
        
        strMyFileName = VBA.Interaction.InputBox("表を含まないファイルの名前を入力してください。", Default:=Format(Date, "yyyy年mm月dd日"))
        
        'InputBoxより取得したファイル名を入力した状態で､名前を付けて保存ダイアログを表示
        With Application.FileDialog(msoFileDialogSaveAs)
            
            .InitialFileName = strMyFileName    'ファイル名の設定

            If .Show = False Then
                Exit Sub  'キャンセル
            Else
               .Execute  '保存
            End If

        End With
        
        'インプットボックスで取得した文字列を初期化
        strMyFileName = ""
        
        End If  '表の有無による条件分岐終了のEndIf

    '画面更新再開
    Application.ScreenUpdating = True

End Sub