【VBA】煩雑なコピペ作業を自動化－#5 プログラムの改善－

前回の記事でほとんど機能的には問題なく、人の数が変わったりしたときにループの回数などを少し手直ししてあげれば問題ないと思います。ただ、いちいちプログラムを変更する必要が生じるので保守性は悪く、数十ファイルと処理対象が増えると結構時間がかかり、性能的にもいまいちです。ここではその点を改善していこうと思います。

5-1. エクセルが処理している様が見えないようにする
5-2. 処理ファイル数をマッピング表から自動で取得する
5-3. 実行時にプログラムを開かなくてもいいようにする
5-4. フォーマット変更に強くする
5-5. 配列で性能改善

5-1. エクセルが処理している様が見えないようにする

前回のプログラムを実行すると入力フォーマットのファイルが開いては消え、開いては消えを繰り返すと思います。これは表示させているだけで時間を使うので、見えないようにします。やり方は簡単です。プログラムの最初に

Application.ScreenUpdating = False

と書いておくだけです。これで実行時にいちいちファイルが開いては閉じ、ということがなくなります。

5-2. 処理ファイル数をマッピング表から自動で取得する

回答者数が増えたときはマッピング表の名前を追加していく必要があります。また、プログラム内のfor文のループの数を増やさないといけません。このfor文の方の修正はなくすことができます。

    Dim ansNum As Integer    '回答者数
        '~~~
    ansNum = wsans.Cells(1, 1).End(xlDown).Row
        '~~~
    For i = 2 To ansNum
        '~~~
    Next

整数変数 ansNum を宣言しておき、wsans.Cells(1, 1) から .End(xlDown) （「Ctrl + ↓」を押したときと同じ動作）をした時の .Row 行番号を取得して、ansNum に代入する。という処理で常に回答者シートのマッピング表の一番下の行を取得するようにします。

5-3. 実行時にプログラムを開かなくてもいいようにする

ボタンを作成して、対応を付けます。
　開発タブ　＞　挿入　＞　ボタンを選択　＞　プログラムの名前（Subの後から()前まで）を選択してOK
これでボタンにマクロが対応するようになります。以降、ボタンをクリックすると登録したマクロが実行されるようになります。

f:id:TKchnmn77:20201027141026p:plain

5-4. フォーマット変更に強くする

列挙型変数という変数を作成します。
プログラムを書き始めの Sub() よりも上に、LISTという列挙型変数の宣言を追加します。日本語で書いているので変な感じがしますが、LIST.名前と書くと1が、LIST.入力日と書くと2が返るようになります。同様に数字が増え、LIST.趣味は5になります。

Public Enum LIST
    名前 = 1
    入力日
    職業
    出身地
    趣味
End Enum

合わせてもう一つ、入力フォーマット側の列挙型変数も作っておきましょう。

Public Enum QUES
    職業 = 5
    出身地
    趣味
End Enum

これだけではいいことはほとんどないのですが、これを使ってコピペしていく箇所のプログラムを変更しています。

【before】

    'コピー&ペーストしていく（一覧のセルに値を代入していく）
        wslist.Cells(p, 1) = ws.Cells(1, 2)   '名前
        wslist.Cells(p, 2) = ws.Cells(2, 2)   '入力日
        wslist.Cells(p, 3) = ws.Cells(5, 3)   '職業
        wslist.Cells(p, 4) = ws.Cells(6, 3)   '出身地
        wslist.Cells(p, 5) = ws.Cells(7, 3)   '趣味

【after】

    'コピー&ペーストしていく（一覧のセルに値を代入していく）
        wslist.Cells(p, LIST.名前) = ws.Cells(1, 2)   '名前
        wslist.Cells(p, LIST.入力日) = ws.Cells(2, 2)   '入力日
        wslist.Cells(p, LIST.職業) = ws.Cells(QUES.職業, 3)   '職業
        wslist.Cells(p, LIST.出身地) = ws.Cells(QUES.出身地, 3)   '出身地
        wslist.Cells(p, LIST.趣味) = ws.Cells(QUES.趣味, 3)   '趣味

いいことは二つあると思います。
　- 何をコピーしているところなのかわかりやすいので、プログラム改修時に間違いが起きにくい。
　- 質問項目を追加したい時、列挙型変数への項目追加とコピペ部分の追加のみで改修が済む
もし、列挙型変数を使わない状態で質問項目が追加、しかも間に追加された場合どうなるでしょう。Cellsで指定していた数字を一つずつ増やして、転記先をずらしてあげないといけません。列挙型変数を使用していれば、列挙型変数の間に入れるだけで自動で番号ずらしが完了するので、楽になります。

5-5. 配列で性能改善

少しアドバンスな内容かもしれません。数十人と回答者が増えてくるとだんだんと処理時間が長くなっていき、再実行する時間コストが気になってくることがあります。エクセルのVBAにおいて、入力（あるセルに値を書くこと）はかなり時間を使う行為になります。配列を使うことでこの入力操作をファイルごとに一回だけにすることができます。

今までのプログラムでは名前～趣味で計5回、セルへの入力を行っていますが、これをいったん配列に格納するように変更します。
注意すべきはVBAにおける配列のデフォルト開始番号は0です。エクセルの列番号と対応させると楽なので、「1 to ~」と記載し、1始まりの配列にしてしまったほうよいです。
配列宣言時にも列挙型変数を使っておくことで、改修時に面倒になる番号ずらしの手間を減らしておきます。

Dim answer(LIST.名前 to LIST.趣味) As String    '回答内容の配列を宣言
        '~~~

    'コピー&ペーストしていく（いったん配列に格納する）
        answer(LIST.名前) = ws.Cells(1, 2)   '名前
        answer(LIST.入力日) = ws.Cells(2, 2)   '入力日
        answer(LIST.職業) = ws.Cells(QUES.職業, 3)   '職業
        answer(LIST.出身地) = ws.Cells(QUES.出身地, 3)   '出身地
        answer(LIST.趣味) = ws.Cells(QUES.趣味, 3)   '趣味

        wslist.Activate

    '一覧に貼り付ける
        wslist.Range(Cells(p, LIST.名前), Cells(p, LIST.趣味)) = answer

上記のようにいったん配列に格納した後に、範囲指定をして配列の中身を一気に貼り付けるようにします。貼り付ける前の wslist.Activate はこれを書かないとRangeメソッドが失敗してしまうために追加しています。正直、アクティブでないシートのRangeメソッドは失敗してしまうから、という説明しかできません。（私の理解不足です。）
諸々追加したプログラムは以下のとおり

Sub ans()

    Application.ScreenUpdating = False

    Dim wblist As Workbook          'コピー先のブック
    Dim wslist As Worksheet         '一覧シート
    Dim wsans As Worksheet          '回答者シート
    Dim wb As Workbook              'コピー元のブック
    Dim ws As Worksheet             'アンケートシート
    Dim foldPath As String          'コピー元のフォルダパス
    Dim fileName As String          'コピー元のファイル名
    Dim p As Integer                'コピー先ポインタ
    Dim ansNum As Integer           '回答者数
    Dim answer(LIST.名前 to LIST.趣味) As String    '回答内容の配列を宣言

'一覧のブックを設定
    Set wblist = Workbooks("アンケート一覧.xlsm")
    Set wslist = wblist.Worksheets("一覧")
    Set wsans = wblist.Worksheets("回答者")

    ansNum = wsans.Cells(1, 1).End(xlDown).Row

'入力フォーマットのブックを設定
    foldPath = "C:\Users\ttakeuchi13\Desktop\VBA\アンケート結果"

    p = 2   '転記先の開始位置

    For i = 2 To ansNum
        fileName = "入力フォーマット_" & wsans.Cells(i, 1) & ".xlsx"
          
        Workbooks.Open (foldPath & "\" & fileName)
        Set wb = Workbooks(fileName)
        Set ws = wb.Worksheets("アンケート")
    
    'コピー&ペーストしていく（いったん配列に格納する）
        answer(LIST.名前) = ws.Cells(1, 2)   '名前
        answer(LIST.入力日) = ws.Cells(2, 2)   '入力日
        answer(LIST.職業) = ws.Cells(QUES.職業, 3)   '職業
        answer(LIST.出身地) = ws.Cells(QUES.出身地, 3)   '出身地
        answer(LIST.趣味) = ws.Cells(QUES.趣味, 3)   '趣味

        wslist.Activate

    '一覧に貼り付ける
        wslist.Range(Cells(p, LIST.名前), Cells(p, LIST.趣味)) = answer
        
        p = p + 1   '転記先を下にずらす
    
    'コピー元は保存しないで閉じる
        wb.Close savechanges:=False
    Next

'今回は閉じずに保存するだけ
   wblist.Save

End Sub