ポムさんのプログラミング奮闘日記

ポムさんのプログラミング奮闘日記

VBAで作ったツールやプログラミングに関することを書きます

⭐️試験結果データで学ぶExcel VBA 実践入門講座⭐️

⭐️notion⭐️を使って
ExcelVBA 講座を作成してみました!
お役に立てると幸いです!

 

notionリンク

https://keen-hardboard-176.notion.site/Excel-VBA-0865ef20a18c48acaa428a7785220d6f


内容

●変数宣言
●オブジェクト変数の利用
 セル範囲を変数へ格納
 ワークシートを変数へ格納
●定数宣言
●メソッドの利用
 ClearCoxtentsによる前回集計値の初期化
●セルへの値の代入
●最終行番号の取得
●最終列番号の取得
●i=i+1 による加算処理
●a=a+b による加算処理
●If文による条件分岐
●繰り返し処理
 For文
DoWhile(1)文
●ユーザー定義関数
 戻り値の無いFunctionプロシージャの利用
●ワークシートに関数の利用
 Average

 

Word VBA『先頭ページのみ別指定』でヘッダーを設定する


今日はWordVBAにおけるヘッダー設定についてお話します。
実は昨日から【先頭ページのみ別指定でのヘッダー設定】で悶絶し、あまりに分からないのでTwitterにつぶやき、朝から再挑戦。ようやく解決できたので、備忘録的に投稿。たとえ一人でも誰かのお役に立てれば幸い。
最初は、ヘッダー設定なんて"そんなの簡単じゃん!"って思っていたわたくし。
ネット検索でコードを参考にするも、どうもうまくいかず。

Documentオブジェクトを指定、Sectionsプロパティでインデックス指定、Headersプロパティで、対象のセクションに含まれるヘッダーを表すHeadersFootersコレクションのインデックスまたは定数を指定、RangeオブジェクトのTextプロパティで文字列を指定。↓こんな感じに。

Application.Documents(2).Sections(1).Headers(wdHeaderFooterFirstPage).Range.Text ="任意の文字列"

これだけでデキルと思い込んでいた。
しかし一向に先頭ページにはヘッダーが設定されず、調べるも分からず。
今朝、あらためて調べていると、そもそも先頭ページのヘッダーに「先頭ページのみ別指定」の設定をまずしてやる必要がありそうだと判明。実行してみるとあら不思議、昨日の悶絶は何だったのか??

で、みつけたのがコレ↓
PageSetup で 「先頭ページのみ別指定」DifferentFirstPageHeaderFooter を True に設定してあげるのです!!

'// ヘッダーを「1ページ目のみ別指定」に設定する! ★これ大事です★ 一手間必要です!
Application.Documents(2).Sections.PageSetup.DifferentFirstPageHeaderFooter = True
'// ヘッダーへ文字列を入力
Application.Documents(2).Sections(1).Headers(wdHeaderFooterFirstPage).Range.Text = "任意の文字列"


※補足※
なお、複数の合ファイルを扱う時などは任意のドキュメントをActivateしたい時があるかもしれません。
そんなときはまず、インデックスで操作したいドキュメントを指定し、Activateしてあげると良いです。
今回私は複数ファイルを扱うのでドキュメントをインデックスで指定しました。

Application.Documents(2).Activate

もし、ファイルが複数あって操作したいドキュメントのファイル名とインデックスが分からなかったら、
下記のようにファイルの数分、インデックスを指定し、イミディエイトウインドウに表示して確認すると良いです。

Debug.Print "インデックス番号1のファイル名; " & Documents(1).Name
Debug.Print "インデックス番号2のファイル名; " & Documents(2).Name
Debug.Print "インデックス番号3のファイル名; " & Documents(3).Name

とくとくデパートの売上額を求める - 繰り返し処理と動的配列 -


前回、繰り返し処理のネストを使って、行方向と列方向のコーディングについてご紹介しました。
前回はただセルの値を表示するだけという簡単な内容でしたが、今回は実際に値を行列方向に加算し、売上一覧を作ってみたいと思います。
特に、小計値である支店別の月別売上を加算しながら、同時に配列を使用して小計値のみを加算する処理を組み合わせます。
小計値のみの加算には RedimPreserve を使用し、配列の要素数(インデックス番号)を支店数に応じて動的に増やしていきます。
はてなブログExcelファイルを添付できればよいのですが、できないようなので、適当に値の入った表を作って試して頂ければ幸いです。

処理前の売上一覧

f:id:Tompsom:20200321122819j:plain
売上一覧処理前

処理後の売上一覧

f:id:Tompsom:20200321122916j:plain
売上一覧処理後

1. 変数および定数の設定と初期化処理

Sub 売り上げ()
    Dim WS                    As Worksheet
    Dim iGyouCnt              As Long    '行カウンタ
    Dim iRetuCnt              As Long    '列カウンタ
    Dim iLastRow              As Long    '終端行番号
    Dim sumBranchSales        As Long    '月ごとの各支店別売上(小計値)
    Dim sales                 As Long    '売上額(セルに入力されている数値)
    Dim arrSubtotal_Branch()  As Variant '支店ごとの月次売り上げ
    Dim cntBranch             As Long    '配列のインデックスに支店数を使用
    Dim sumMonthly            As Long    '支店ごとの月次売り上げの加算用変数
    Dim sumHalfYear           As Long    '半期の商品別売り上げを格納
    Dim sumAllSales           As Long    '全売り上げの合計値
    
    '行番号
    Const rTOP_PosY           As Long = 2 '表の先頭行番号
    Const rDATA_PosY          As Long = 3 'データの先頭行番号
    
    '列番号
    Const SHITEN_PosX         As Long = 1 '支店列番号
    Const ITEM_PosX           As Long = 2 '商品列番号
    Const cDATA_PosX          As Long = 3 'データの先頭列番号
    
    Set WS = Worksheets("Sheet1")   'Sheet1をオブジェクト変数WSに格納
    
    '終端行の取得
    iLastRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
    
    '列カウンタ初期化
    iRetuCnt = 0
    '行カウンタ初期化
    iGyouCnt = 0

2.支店別売上を入力するための小計行を自動挿入

⇒支店名列を上から下へ走査するだけなので、ループのネストはなし

    Do While (1)
        '支店名列を終端行から上方向に走査、支店名セル(A2セル)を指したら終了
        If WS.Cells(iLastRow - iGyouCnt, SHITEN_PosX).Value = "支店名" Then
            Exit Do
        End If

        '小計行を入力
        If InStr(WS.Cells(iLastRow - iGyouCnt, SHITEN_PosX), "支店") <> 0 And _
           WS.Cells(iLastRow - iGyouCnt - 1, SHITEN_PosX).Value = "" Then
            WS.Rows(iLastRow - iGyouCnt).Insert
            WS.Cells(iLastRow - iGyouCnt, ITEM_PosX).Value = "小計"
            
            '小計セルの下側罫線を引き、上側の罫線を消す
            With WS.Cells(iLastRow - iGyouCnt, SHITEN_PosX)
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlLineStyleNone
            End With
        End If
        
        iGyouCnt = iGyouCnt + 1
    Loop
   
    iGyouCnt = 0
    

3.小計値を求める(月ごとの支店別売り上げ) & 月別全支店売上を求める

⇒列方向と行方向の合わせ技
(4月A支店→D支店 ⇒ 5月A支店→D支店 ⇒6月⇒7月⇒8月⇒9月A支店→D支店)
4月期A支店の商品aaaから商品eeeの売上を順に加算処理し、小計行を指したら値をセルへ出力
次はB支店の4月を処理、同様にD支店まで処理し、商品列が空白セルを指したら列カウンタをインクリメントし、5月を処理。
〔 加算処理の仕組み 〕
簡単に説明すると
⇒ a=a+b(aは加算値を格納する変数、bは足し込んでいきたい個々のセル値。右辺a+bの結果を左辺へ格納)
⇒ 加算値を格納する変数をカウンタ変数のように使用し、売り上げ額を足し込んでいく
 今回の場合だと、、、
売り上げセルの値が「0」ではない場合【注2】、加算処理【注3】
sumBranchSales の初期値;0ゼロ、A支店の商品aaaの4月の値は125より、
右辺の「sumBranchSales + sales」は sumBranchSales『0』 + sales『125』となり、
左辺のsumBranchSalesには125が代入される。
行カウンタがインクリメント【注4】され、商品bbbの値568が変数 sales に格納される。よって、
右辺のsumBranchSalesには最初の商品aaaの値125が格納されており、変数salesには
新しく商品bbbの値568が格納されている。つまり
右辺 sumBranchSales『125』 + sales『568』 の計算結果693が左辺のsumBranchSalesに格納される【注1】。
これを繰り返し、小計セルに到達【注5】したら、左辺の加算値をセルへ代入する【注6】
セルへ代入後、加算値(sumBranchSales)を初期化【注7】し、 行カウンタがインクリメント【注4】され、次の支店の処理が始まる。
内側ループの終了条件を満たしたら【注8】、外側ループへ移動し終了条件チェックし、
外側終了条件を満たさないなら再び内側ループへ入る、を外側ループの終了条件を満たすまで繰り返す。

    '外側ループ;項目行を走査し、商品別売上合計を指したら終了
    Do While (1)
        If WS.Cells(rTOP_PosY, cDATA_PosX + iRetuCnt).Value = "商品別売上合計" Then
            Exit Do
        End If
        
        '内側ループ;商品列を走査、空白セルを指したら終了
        Do While (1)
            If WS.Cells(rDATA_PosY + iGyouCnt, ITEM_PosX).Value = "" Then  '【注8】
                Exit Do
            End If

            '各売り上げを変数 sales へ格納
            sales = WS.Cells(rDATA_PosY + iGyouCnt, cDATA_PosX + iRetuCnt).Value  '【注1】
            '売り上げがゼロではない場合に加算
            If sales <> 0 Then '【注2】
                sumBranchSales = sumBranchSales + sales '【注3】
            End If

            '小計行を指したら、加算値(月ごとの支店別売り上げ)をセルに出力。
            '加算値を初期化する。            
            
            '小計行かどうかをチェック
            If WS.Cells(rDATA_PosY + iGyouCnt, ITEM_PosX).Value = "小計" Then '【注5】
                
                '小計行なら加算してきた値(sumBranchSales)をセルへ出力
                WS.Cells(rDATA_PosY + iGyouCnt, cDATA_PosX + iRetuCnt).Value = sumBranchSales '【注6】
                
                '月別の全支店売り上げを求めるために、小計値を順に配列へ格納していきます。
                'この処理は配列を使用せずとも小計値と同様に加算処理でも可能ですが、配列の使い方を紹介したいので、あえて配列を使用します。
                '配列の要素数は支店の数ですが、”支店数の変動に対応する”ために一工夫します。
                ' ⇒RedimPreserveを使用して配列の要素数を動的に変動させます。
                ' ⇒配列のインデックスには支店の数を表すカウンタ変数(cntBranch)を使用し、配列へ格納するたびにインクリメントします。
                ' ⇒こうすることで、要素数を増加させながら配列に値を格納することが可能です。
                ' ⇒つまり、条件に合わせて、必要なものを、必要な数だけ、配列に格納することが可能です。
                ' ⇒私もこれを見つけた時はほんと感動!
                
                ReDim Preserve arrSubtotal_Branch(cntBranch)
                arrSubtotal_Branch(cntBranch) = sumBranchSales
                
                '支店ごとの月次売上を加算処理する
                '加算値用の変数=加算値用の変数+小計値のみを格納した配列
                sumMonthly = sumMonthly + arrSubtotal_Branch(cntBranch)
                
                '支店の数をカウントする
                cntBranch = cntBranch + 1
                
                '支店ごとの小計値を初期化し、次の支店の小計値を格納するための処理
                sumBranchSales = 0 '【注7】
            End If
            
            '↓どうしてこの位置で行カウンタをインクリメントしたか?
            ' ( = どうして内側ループのLoopの記述直前★★ではないのか?)
            '内側ループの終了条件が商品列(B列)のセルが空白セルの場合だから。
            '   ⇒D支店の小計値代入後すぐに、月別全支店売上の行かどうかをチェックしても、
            '     小計行のままなので、セルへの出力は実行されず、If文を抜ける。
            '     行カウンタインクリメントで次の行へ移動するものの、空白セルのため、
            '     内側ループの終了条件を満たしてしまい、次別合計をセルへ出力せずに次の列へ移ってしまうから。
            '月別全支店売上のIf文直前で行カウンタをインクリメントさせることで、最後のD支店の小計値を入力後すぐに
            '月別全支店売上のセルを指すことができ、月別全支店売上をセルへ出力することができる。
            
            '行カウンタをインクリメントし、次の支店へ。
            iGyouCnt = iGyouCnt + 1 '【注4】
            
            '月別全支店売上を指したらセルへ加算値を出力
            If WS.Cells(rDATA_PosY + iGyouCnt, SHITEN_PosX).Value = "月別全支店売上" Then
                WS.Cells(rDATA_PosY + iGyouCnt, cDATA_PosX + iRetuCnt).Value = sumMonthly
                sumMonthly = 0
            End If
            
        Loop '★★

        '内側ループを抜けたら
        '  列カウンタをインクリメント ⇒1つ右の列(月)へ
        '  行カウンタを初期化         ⇒A支店に戻す
        iGyouCnt = 0
        iRetuCnt = iRetuCnt + 1
    Loop
       
    '変数の初期化
    iRetuCnt = 0
    cntBranch = 0
        
    '終端行を再取得
    iLastRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
    

4.商品別売上合計を求めます

⇒行ごとに処理を行います

    Do While (1)
        If WS.Cells(rDATA_PosY + iGyouCnt, ITEM_PosX).Value = "" Then
            Exit Do
        End If
        
        Do While (1)
            'C2セルから右方向へ走査し、空白セルのJ列を指したら列カウンタを「0ゼロ」に戻す。
            '⇒つまり4月に戻る
            If WS.Cells(rTOP_PosY, cDATA_PosX + iRetuCnt).Value = "" Then
                iRetuCnt = 0
                Exit Do
            End If
        
            'セルの値が空白セルではない場合、セルの値を加算する
            If WS.Cells(rDATA_PosY + iGyouCnt, cDATA_PosX + iRetuCnt).Value <> "" Then
                sumHalfYear _
                = sumHalfYear + WS.Cells(rDATA_PosY + iGyouCnt, cDATA_PosX + iRetuCnt).Value
            End If
            
            '商品別売上合計を指したら加算値をセルへ出力し、値を初期化
            If WS.Cells(rTOP_PosY, cDATA_PosX + iRetuCnt).Value = "商品別売上合計" Then
                WS.Cells(rDATA_PosY + iGyouCnt, cDATA_PosX + iRetuCnt).Value = sumHalfYear
                sumHalfYear = 0
            End If

            '月が変わる
            iRetuCnt = iRetuCnt + 1
    
        Loop
    
    'ひとつ下の商品へ移動する
    iGyouCnt = iGyouCnt + 1
    
    Loop
    
    '終端行を再取得
    iLastRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
    

5.全支店全売上額を求める

⇒1行のみの加算処理で列の走査はないので、ループ処理のネストはありません。

    '終端行の1行下に"全支店全売上額"と入力する
    WS.Cells(iLastRow + 1, SHITEN_PosX).Value = "全支店全売上額 "
    
    '月別全支店売上の行を右方向に走査し、空白セルを指したら加算処理を終了し、加算値をセルへ代入、罫線を引き、繰り返し処理を抜ける
    Do While (1)
        If WS.Cells(iLastRow, cDATA_PosX + iRetuCnt).Value = "" Then
            '加算値(全合計)をセルへ代入
            WS.Cells(iLastRow + 1, ITEM_PosX).Value = sumAllSales
            
            With WS.Range( _
                WS.Cells(iLastRow + 1, SHITEN_PosX), WS.Cells(iLastRow + 1, ITEM_PosX)) _
                .Borders(xlEdgeBottom)     'セルの下側に
                .LineStyle = xlContinuous  '罫線(実線 細い)を引き、
                .Weight = xlThick          '太さを太いに設定
            End With
            
            Exit Do '繰り返し処理を抜ける
        End If
        
        '月別全支店売上額を加算処理(加算値=加算値 + 加算したい個々の値)
        '左辺月ごとに一つずつかか)
        If WS.Cells(iLastRow, cDATA_PosX + iRetuCnt).Value <> "" Then
            sumAllSales = sumAllSales + WS.Cells(iLastRow, cDATA_PosX + iRetuCnt).Value
        End If
        
        '月が変わる
        iRetuCnt = iRetuCnt + 1
    
    Loop

End Sub

Do While(1)の無限ループ を使った繰り返し処理入門 2 - 列ごとに処理をしたい場合 -


前回、行ごとに処理を行う場合の繰り返し処理の書き方をご紹介しました。
今回は列ごとに処理を行う場合です。

★★ 行ごとに処理を実行する場合との違い ★★
● 項目名行の行番号を定数に追加。前回の商品名列番号の定数(ITEM_PosX)は不要なのでを削除
●外側のループを抜ける場合の終了条件
 ⇒行番号は項目名行の2行目に固定し、列方向のみにカウンタ変数を使用【2】
●内側ループの終了条件を満たした時に、行カウンタを初期化。【7】
●内側ループを抜けた後に列カウンタをインクリメント【13】
●実行したい処理の後に行カウンタをインクリメント【11】

列ごとに処理を行う場合のセルの処理イメージはこんな感じ

f:id:Tompsom:20200314161819j:plain
列ごとに繰り返し処理


サンプルコードで使用する表は行ごとに処理を行う場合に使用したものと同様です

f:id:Tompsom:20200314124648j:plain
とくとくデパート支店別売上一覧

Sub 列ごとに繰り返し処理()

    Dim iGyouCnt           As Long     '行のカウンタ変数
    Dim iRetuCnt           As Long     '列のカウンタ変数

    Const RETU_KAISHI_PosX As Long = 3 '走査対象セルの最初の列番号
    Const KOUMOKUMEI_PosY  As Long = 2 '項目名の行番号
    Const GYOU_KAISHI_PosY As Long = 3 '走査対象セルの最初の行番号
    
    '< 外側のループ >
    '終了条件;3行目の「RETU_KAISHI_PosX + iRetuCnt」列目のセルの値が空白("")かどうか?
    '終了条件をチェックしながら、3行目「B3セル」から右方向へ走査する。
    '空白ではない間、【5】~【12】の処理を繰り返す。
    '終了条件を満たした場合の処理
    '    ⇒外側のループを抜ける(【3】)
    '    ⇒プロシージャを終了する【15】
    '大切なのは内側ループの列番号の指定と同じにすること。こうすることで、
    '    ①内側ループ終了条件(【6】)を満たして内側ループを抜け(【8】)、
    '    ②行カウンタがインクリメント(【13】)された時点で、走査対象のセルが1行下に移動する
    '    ③移動した1行下のセルが空白セルなら(【2】)、外側の繰り返し処理も抜けることができる。
    
    Do While (1)  '【1】
        If Worksheets("Sheet1").Cells(KOUMOKUMEI_PosY, RETU_KAISHI_PosX + iRetuCnt).Value = "" Then '【2】
            Exit Do   '【3】
        End If        '【4】
        
        '<< 内側のループ >>
        '終了条件;走査中のセルが空白セルかどうか?(【6】)
        '終了条件をチェックしながら、C列3行目「C3セル」から下方向へ走査する。
        '実行したい何らかの処理(【10】)後、行カウンタをインクリメント(【11】)することでセルは下方向へ移動する。
        'いずれ数値の入力されていない空白セルが走査される時がやってくる。
        '  終了条件を満たした場合の処理
        '    ⇒行カウンタを0に戻し (【7】)
        '    ⇒繰り返し処理を抜ける  (【8】)
        '    ⇒列カウンタをインクリメント(【13】)
        '    ⇒外側ループへ移動(【1】)
        '    ⇒外側ループのの終了条件(【2】)をチェック
        '    ⇒満たさない場合は再度内側ループへ移動(【5】)

            Do While (1)         '【5】
                If Worksheets("Sheet1").Cells(GYOU_KAISHI_PosY + iGyouCnt, RETU_KAISHI_PosX + iRetuCnt).Value = "" Then '【6】
                    '列ごとに処理をしたいので、終端行まで移動したら、行カウンタを初期化することで、3行目に戻す
                    iGyouCnt = 0 '【7】
                    Exit Do      '【8】
                End If           '【9】
            
                '<<< 行いたい処理__START >>>
                
                '走査中のセルの値をイミディエイトウインドウに表示する
                Debug.Print Worksheets("Sheet1").Cells(GYOU_KAISHI_PosY + iGyouCnt, RETU_KAISHI_PosX + iRetuCnt).Value '【10】
            
                '<<< 行いたい処理__END   >>>
                
                '列ごとに処理をしたいので、内側のループは行をインクリメントしながら進む
                iGyouCnt = iGyouCnt + 1  '【11】
                
            Loop  '【12】

        '列ごとに処理をしたいので、内側ループを抜けたら列カウンタをインクリメント
        iRetuCnt = iRetuCnt + 1  '【13】
        
        Loop  '【14】

End Sub

Do While(1) の無限ループを使った繰り返し処理入門 1 - 行ごとに処理をしたい場合 -


今回は DoWhile(1) を使った繰り返し処理のネスト(2重ループ)について書きたいと思います。
Excelのワークシートを処理する場合に、行ごとに処理したい時と、列ごとに処理をしたい時の2つの場合がありますよね。
今回は行ごとに処理を行いたい場合の繰り返し処理の書き方についてご説明したいと思います。

1回目は行ごとに処理を実行したい場合の書き方です。
行ごとの繰り返し処理のイメージはこんな感じ。実際のサンプルコードでは支店が4つある表を使用します。

f:id:Tompsom:20200314123354j:plain
行ごとの繰り返し処理

紹介するサンプルコードに使用する表は次の通りです
とくとくデパートの売上一覧を使います。
ここでは繰り返し処理の説明のみなので、行う処理はセルの値(売上額)をイミディエイトウインドウに表示するだけです。

f:id:Tompsom:20200314124648j:plain
とくとくデパート支店別売上一覧

Sub 繰り返し処理のネスト_2重ループ()

    Dim iGyouCnt           As Long     '行のカウンタ変数
    Dim iRetuCnt           As Long     '列のカウンタ変数
    
    Const ITEM_PosX        As Long = 2 '商品列の列番号
    Const RETU_KAISHI_PosX As Long = 3 '走査対象セルの最初の列番号
    Const GYOU_KAISHI_PosY As Long = 3 '走査対象セルの最初の行番号
           
    'ループ処理の終了条件は DoWhile(1) の直下に記述。""は長さゼロの空文字列を表し、Valueに続いて=記号で書くことで、空白セルを表します。
    '終了条件は状況によって変わります。都度適切な条件を指定します。
    '終了条件の例:
    '  ⇒空白セルもしくは空白ではないセル
    '  ⇒特定の文字列(セルの値、セルの一部の文字列(文字列関数を使用))

    '< 外側のループ >
    '終了条件;B列の「GYOU_KAISHI_PosY + iGyouCnt」行目のセルの値が空白("")かどうか?
    '終了条件をチェックしながら、B列3行目「B3セル」から下方向へ走査する。
    '空白ではない間、【5】~【12】の処理を繰り返す。
    '終了条件を満たした場合の処理
    '    ⇒外側のループを抜ける(【3】)
    '    ⇒プロシージャを終了する【15】
    '大切なのは内側ループの行指定と同じにすること。こうすることで、
    '    ①内側ループ終了条件(【6】)を満たして内側ループを抜け(【8】)、
    '    ②行カウンタがインクリメント(【13】)された時点で、走査対象のセルが1行下に移動する
    '    ③移動した1行下のセルが空白セルなら(【2】)、外側の繰り返し処理も抜けることができる。
        
    Do While (1)  '【1】
        If Worksheets("Sheet1").Cells(GYOU_KAISHI_PosY + iGyouCnt, ITEM_PosX).Value = "" Then '【2】
            Exit Do   '【3】
        End If        '【4】
        
        '<< 内側のループ >>
        '終了条件;走査中のセルが空白セルかどうか?(【6】)
        '終了条件をチェックしながら、C列3行目「C3セル」から右方向へ走査する。
        '実行したい何らかの処理(【10】)後、列カウンタをインクリメント(【11】)することでセルは右方向へ移動する。
        'いずれ数値の入力されていない空白セルが走査される時がやってくる。
        '  終了条件を満たした場合の処理
        '    ⇒列カウンタを0に戻し (【7】)
        '    ⇒繰り返し処理を抜ける  (【8】)
        '    ⇒行カウンタをインクリメント(【13】)
        '    ⇒外側ループへ移動(【1】)
        '    ⇒外側ループのの終了条件(【2】)をチェック
        '    ⇒満たさない場合は再度内側ループへ移動(【5】)
            Do While (1)         '【5】
                If Worksheets("Sheet1").Cells(GYOU_KAISHI_PosY + iGyouCnt, RETU_KAISHI_PosX + iRetuCnt).Value = "" Then '【6】
                    iRetuCnt = 0 '【7】
                    Exit Do      '【8】
                End If           '【9】
            
                '<<< 行いたい処理__START >>>
                
                '走査中のセルの値をイミディエイトウインドウに表示する
                Debug.Print Worksheets("Sheet1").Cells(GYOU_KAISHI_PosY + iGyouCnt, RETU_KAISHI_PosX + iRetuCnt).Value '【10】
            
                '<<< 行いたい処理__END   >>>
                
                iRetuCnt = iRetuCnt + 1  '【11】
            Loop  '【12】
        
        iGyouCnt = iGyouCnt + 1  '【13】
    Loop  '【14】

End Sub  '【15】

テスト結果を集計(セル範囲を配列へ一括格納/配列内を走査し計算処理後に別の配列へ格納)


点数一覧で使用している氏名は、全て下記のサイトを利用して疑似的に生成したものであり、実際のものではありません。
https://hogehoge.tk/personal/generator/
また、点数についても適当に入力したものであり、実際の個人のものではありません。

今回は配列を使った処理について書いてみました!
やることはタイトルにも書いたけど、次の3つになります。
1)セル範囲を配列へ一括格納
2)配列内を走査し、計算処理後に別の配列へ格納
3)配列の内容をセルへ一気に出力

今回使用するのは
学生番号、氏名、国語、英語、数学、理科、社会、合計点の全8項目を含む一覧表
学生別の全合計を出力します。そんなの、ワークシート関数SUMで俺でもできるじゃん!って言われそうですが・・・・(笑)

f:id:Tompsom:20200202104911p:plain
試験結果

1.変数の宣言と科目数のカウント

Option Explicit

Sub 配列を使ってテスト集計()

Dim iRowsCnt         As Long    '行カウンタ
Dim iColCnt          As Long    '列カウンタ
Dim iSubjectsCnt     As Long    '科目数カウンタ
Dim iStudentCnt      As Long    '学生数カウンタ(合計点を配列 arrTotalScore に格納する際のインデクス番号に使用) ※【2】※

Dim iTotalStudents   As Long    '全学生数※【1】※
Dim iLastStudentRow  As Long    '学生列の終端行番号
Dim iLastSubject     As Long    '最後の科目の列番号
Dim arrTestScore     As Variant '学生ごとの各科目の点数を格納する配列変数
Dim arrTotalScore    As Variant '全学生の合計点のみを格納する配列変数
Dim sumTotalScore    As Long    '個々の学生の点数を1科目ずつ加算し格納
Dim x                As Long    '配列 arrTestScore内を走査するための列方向のインデックス番号
Dim y                As Long    '配列 arrTestScore内を走査するための行方向のインデックス番号

'WorkSheets("Sheet1")以外からの実行に対応させるために計算のためのワークシートを変数へ格納
Dim wsKeisan  As Worksheet
Set wsKeisan = Worksheets("Sheet1")
  
'行番号
Const iRowsStartPosY     As Long = 1    '一覧の先頭行番号
Const iStudentStartPosY  As Long = 2    '学生の先頭行番号

'列番号
Const iStudentNoPosX     As Long = 1    '学生番号列
Const iStudentNamePosX   As Long = 2    '学生氏名列
Const iSubjectsStartPosX As Long = 3    '科目名開始列

    '初期化
    iRowsCnt = 0
    iColCnt = 0
    iTotalStudents = 0
    
    '★ Do While (1)  って何?? _
         Do While(1) は無限ループを使用した繰り返し処理の方法 _
         Do While(1)の直下に終了条件を書かないと無限ループに陥りますのでご注意を。 _
         下の例だと、1行目の項目名を走査し、合計点のセルを指したら処理を終了し、ループを抜けます。
    
    ' // 科目数をカウント。 _
         ループ処理は1行目を走査し、全合計セルを指したら終了
    Do While (1)
        If Worksheets("Sheet1").Cells(iRowsStartPosY, iSubjectsStartPosX + iColCnt).Value = "合計点" Then
            iColCnt = 0
            Exit Do
        End If
    
        If Worksheets("Sheet1").Cells(iRowsStartPosY, iSubjectsStartPosX + iColCnt).Value <> "" Then
            iSubjectsCnt = iSubjectsCnt + 1
        End If
    
        ' // 列カウンタをインクリメント
        iColCnt = iColCnt + 1
    Loop

Stop  '動作チェック用のStopステートメント。ここで一時停止します。不要でしたら削除してください。

2.前回集計時の合計点が存在したら自動削除

    ' // 前回集計時の合計点が存在したら自動削除
    '1列目の学生番号列を走査し、空白セルを指したら終了。
    Do While (1)
        If Worksheets("Sheet1").Cells(iRowsStartPosY + iRowsCnt, iStudentNoPosX).Value = "" Then
            iRowsCnt = 0
            Exit Do
        End If
    
        ' // 合計点セル(学生氏名列番号 + 科目数 + 1 は合計点列の列番号)が空白セルではない場合は値を削除(空文字を代入)
        If Worksheets("Sheet1").Cells(iStudentStartPosY + iRowsCnt, iStudentNamePosX + iSubjectsCnt + 1).Value <> "" Then
            Worksheets("Sheet1").Cells(iStudentStartPosY + iRowsCnt, iStudentNamePosX + iSubjectsCnt + 1).Value = ""
        End If
    
        ' // 列カウンタをインクリメントし次の科目へ移動
        iRowsCnt = iRowsCnt + 1
        
    Loop

Stop  '動作チェック用のStopステートメント。不要でしたら削除してください。

3.学生数をカウント

    ' // 学生数をカウントし配列のインデックスに使用 ※【1】※
    Do While (1)
        If Worksheets("Sheet1").Cells(iRowsStartPosY + iRowsCnt, iStudentNoPosX).Value = "" Then
            iRowsCnt = 0
            Exit Do
        End If
    
        ' // 学生番号列を走査し、学生番号が空白セルではない場合にカウンタを加算して人数をカウント
        If Worksheets("Sheet1").Cells(iStudentStartPosY + iRowsCnt, iStudentNoPosX).Value <> "" Then
        
            ' // 学生数カウンタを加算
            iTotalStudents = iTotalStudents + 1
            
        End If
    
        '行カウンタをインクリメント
        iRowsCnt = iRowsCnt + 1
    Loop
    
    iColCnt = 0
    
Stop  '動作チェック用のStopステートメント。不要でしたら削除してください。

4.個人のテストの点数を配列に格納後、配列内をループ処理し、合計点算出、合計点のみを別の配列に格納

    ' // 最後の学生の行番号を取得(学生数+1(項目行))
    iLastStudentRow = iTotalStudents + 1
       
    ' // 今回の投稿の醍醐味!テストの点数のみを配列へ一括格納 _
         セル範囲の指定は Range(処理対象のワークシートを格納した変数.Cells(行番号,列番号),処理対象のワークシートを格納した変数.Cells(行番号,列番号)) という形式で指定します。 _
          初回投稿時にはココの 「処理対象のワークシートを格納した変数.」 が抜けていたため、他のワークシートからの実行ができないとご指摘をうけ、修正致しました。

    arrTestScore = wsKeisan.Range(wsKeisan.Cells(iStudentStartPosY, iSubjectsStartPosX), wsKeisan.Cells(iLastStudentRow, iStudentNamePosX + iSubjectsCnt)).Value
    
    ' // 合計点をまとめて格納する配列の要素数を学生数 で再定義 ※【1】※
    ReDim arrTotalScore(1 To iTotalStudents)
    
    ' // 初期化処理
    sumTotalScore = 0
  
    ' // 学生数カウンタを1で初期化
    iStudentCnt = 1 
  
    For y = LBound(arrTestScore, 1) To UBound(arrTestScore, 1)      ' 学生(=行方向)
        For x = LBound(arrTestScore, 2) To UBound(arrTestScore, 2)  ' 科目(=列方向)
            Debug.Print arrTestScore(y, x)
      
            ' // 1科目ずつ点数を加算処理
            sumTotalScore = sumTotalScore + arrTestScore(y, x)
            Debug.Print "sumTotalScore" & sumTotalScore
            
        Next x  

        ' // 今回欲しいのは合計点のみ。合計点のみを別の配列(arrTotalScore)へ一人ずつ順に格納。要素数は学生数(iStudentCnt) ※【2】※
        arrTotalScore(iStudentCnt) = sumTotalScore
    
        ' // 学生数カウンタをインクリメントし次の学生に移動。
        iStudentCnt = iStudentCnt + 1
    
        ' // 合計点を初期化
        sumTotalScore = 0
    Next y
  

個人のテスト結果が配列に格納されていますね!  arrTestScore

f:id:Tompsom:20200202104236p:plain

合計点数のみを格納した配列  arrTotalScore

f:id:Tompsom:20200202104559p:plain

5.全合計をセルへまとめて出力

    ' // 全合計をセルへまとめて出力
    ' //  一次元配列は横方向にしか一括代入できないので、縦方向にするためにワークシート関数の「Transpose関数」を用いる
    ' //  Transpose関数はワークシートでよく使う「形式を指定して貼り付け」の「行列の入れ替え」のこと。
    wsKeisan.Range(wsKeisan.Cells(2, 8), wsKeisan.Cells(11, 8)).Value = WorksheetFunction.Transpose(arrTotalScore)

Stop  '動作チェック用のStopステートメント。不要でしたら削除してください。

' // 配列を初期化
Erase arrTestScore
Erase arrTotalScore

' // ワークシートオブジェクトの参照を解除
Set = wsKeisan=Nothing

End Sub   

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


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

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

さぁ、いってみよう!
今回、複数のファイルを1つにまとめるための大きな枠組み、仕組みづくりに参考にさせて頂いたサイトはこちらです。
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 = "MS ゴシック"
    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* の意味
次の2つを組み合わせることでファイル名のみを取得することが出来る
[1] \* ⇒ \記号を含む任意の文字列を指定
[2] .docx* ⇒ .docx を含む任意の文字列を指定
 ・ 引用元サイトTipsfound 様のサイトより一部引用(閲覧日時2019.09.14)
www.tipsfound.com

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

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

    ' 複数のWordファイルを1つに集約するための新規ドキュメントを作成し、ドキュメント末尾に追記
    '新規ドキュメント作成
    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つにまとめた文書のページ設定を行う

    '文書の各セクションに対して余白を設定 _
     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やExcelVBA(マクロ)を有効に活用しましょう!
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 )が0なら表は存在しない。
    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つの場合は4×4=16列の表を作成) _
         '行数未指定の場合:初期値として転記元の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
        
        ' **************
        ' 表転記処理開始
        ' **************
        '転記する表の数は転記用の表を除くので、全ての表の数から1を引いた数となります
        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 と記述した理由 ↓
                    '列カウンタが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. 文書末尾に作成した表のみをコピーして新規ドキュメントに貼り付け

        '文書末尾に1つにまとめた表を選択、コピー
        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