【VBA】煩雑なコピペ作業を自動化-#4 複数ファイルの記載を一覧化する-

ではいよいよ、あるきまったフォーマットのファイルを一覧化するプログラムを作成していきたいと思います。
問題を定義して、その後に書いていくところを順に説明していきたいと思います。

Q. 自動化したい作業

以下のような簡単なアンケートフォーマットがあるとします。


f:id:TKchnmn77:20201026144201p:plain


たくさんの人(ファイル量産が面倒なので今回は3人)が回答してくれたアンケートが「アンケート結果」フォルダに入っているとします。この中身を一覧にする作業を自動化してください。


f:id:TKchnmn77:20201026144230p:plain





A-1. コピー先の一覧ファイルを作る

何はともあれまとめる一覧を作らないといけません。項目が網羅的にはいっていればいいので、


f:id:TKchnmn77:20201026160159p:plain


こんな一覧にしておきます。
また、今回はこのファイルに直接プログラムを書くので、「.xlsm」形式で保存しておきます。

A-2. まずは1ファイルをコピペする

まずは動かせるものを作るのがなによりなので、1ファイルだけコピペするプログラムを組んでみます。

  1. 「Alt + F11」でエディタを開きましょう
  2. 「プロジェクト - VBAproject」枠の中で右クリック > 挿入 > 標準モジュールを選択
  3. プログラムを書いていく(前記事のプログラムも参考に)

  - 一覧化するファイルとコピー元の入力フォーマットの二つのWorkbookオブジェクトとWorksheetオブジェクトが必要になります。
  - コピペするところは地道にセル同士の対応を考えてセルを指定していきます。

Sub ans()

   Dim wblist As Workbook   '一覧のブック
   Dim wslist As Worksheet   '一覧シート
   Dim wb As Workbook   'コピー元(入力フォーマット)のブック
   Dim ws As Worksheet   'コピー元のアンケートシート
   Dim foldPath As String   'アンケート結果フォルダのパス
   Dim fileName As String   '入力フォーマットのファイル名

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

'入力フォーマットのブックを設定
   foldPath = "C:\Users\user1\Desktop\アンケート結果"
   fileName = "入力フォーマット_Aさん.xlsx"
   Workbooks.Open (foldPath & "\" & fileName)
   Set wb = Workbooks(fileName)
   Set ws = wb.Worksheets("アンケート")

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

'コピー元は保存しないで閉じる
   wb.Close savechanges:=False

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

End Sub

これを書いて実行をすると


f:id:TKchnmn77:20201026161716p:plain


こんな感じで値が入力された状態になります。あとはこれをBさん、Cさんと繰り返していけるようループを作れれば完成です。
ちなみに入力日が変な数字になってますがこれはエクセルの書式を日付に変更すれば直ります。

A-3. ループを追加して全ファイル処理できるようにしよう

A-2まででAさんのファイルは一覧に転記できました。これをBさん、Cさんと繰り返すことができれば実行するだけでどんなに人が多くても一覧は一瞬で作れるようになります。ただし、ここで問題になるのが、ファイル名に数字がない点です。前記事の問題ではファイル名に数字があったので、それを使ってループ処理を回すことができました。今回はAさん、Bさんと数字ではないものが固定ファイル名についているので、やり方を工夫しなくてはいけません。ここでは二つの方法を紹介します。

A-3-1. マッピング表を作ってループ

一つ目の方法が1番目がAさん、二番目がBさんといったマッピング表をエクセル上に作成し、その表でループする方法です。
処理するファイル数と下記のようにどんなファイル名かわかっている場合はこの方法を推奨します。余計なファイルなどを処理しないためにも、ちょっとカッコ悪いですがファイル名をきちんと指定するのがおすすめです。


 - 入力データシート_販売管理.xlsx
 - 入力データシート_在庫管理.xlsx
 - 入力データシート_仕入管理.xlsx


 - アンケートシート_鈴木.xlsx
 - アンケートシート_田中.xlsx
 - アンケートシート_佐藤.xlsx


面倒ではありますが、一覧化するファイルの別シートに対象文言の一覧を作成しましょう。今回の場合は以下の感じです。


f:id:TKchnmn77:20201026163029p:plain


そしてループする際には順にこの「回答者」シートのセルを一つずつ使ってファイル名を変更していけばよいのです。

   Dim wsans As Worksheet
   Set wsans = wblist.Worksheets("回答者")

   for i = 2 to 4
      fileName = "入力フォーマット_" & wsans.Cells(i, 1) & ".xlsx"
      'ファイルの処理を記載
   Next


こうすると i = 1 の時:Aさん、i = 2 の時:Bさん、i = 3 の時:Cさん、となっていきます。

A-3-2. フォルダの中のファイルを全部処理

もう一つはフォルダの中のファイルをすべて処理する方法。処理するファイル数がいつも違う場合や、ファイル名が固定ではない場合はこの方法を使います。
Dir()コマンドを使って、プログラムは以下のようになります。

   fileName = Dir(foldPath & "*.*")       '1番目のファイル名を取得
      '最初のファイルの処理を記載
   Do Until fileName = ""                      'ファイル名が空欄になるまで繰り返す
       fileName = Dir()                            '次のファイル名を取得
      'ファイルの処理を記載
   Loop


A-4. 【完成】一覧への記載行側のループ処理

次に、コピー元の方はファイルを次々に読むことが来ましたが、このままだと一覧に転記する先がずれていかないので、常に2行目に上書きしていってしまうことになります。これは別に変数(p(ポインターの略))を設けて、ループするごとに +1 していき、転記先の行を少しずつずらすようにします。

Sub ans()

    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

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

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

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

    For i = 2 To 4
        fileName = "入力フォーマット_" & wsans.Cells(i, 1) & ".xlsx"
          
        Workbooks.Open (foldPath & "\" & fileName)
        Set wb = Workbooks(fileName)
        Set ws = wb.Worksheets("アンケート")
    
    'コピー&ペーストしていく(一覧のセルに値を代入していく)
        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)   '趣味

        p = p + 1   '転記先を下にずらす
    
    'コピー元は保存しないで閉じる
        wb.Close savechanges:=False
    Next

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

End Sub


これを実行すると


f:id:TKchnmn77:20201026164456p:plain


こうなれば成功です。(入力日の書式は手動で変換しています。)