EXCEL VBA 複数ファイル・ブックの集計処理・１つのワークシートにまとめる（テクニック）

2020年2月13日

EXCEL VBA 複数ファイル・ブックの集計処理・１つのワークシートにまとめる（テクニック）

●はじめに

社内の事務処理で、アンケートなど配布しそれを集計する作業があると思いますが、紙によるアンケートを配布し、集計するとなると無駄な作業が多くなり、作業に時間が掛かってしまいます。しかし、EXCELファイル等を配布してファイルを回収しても、手動でデータを入力または、「コピー貼り付け」などで纏めると、それもまた時間が掛かってしまいます。集めた複数ファイルが数百～数千件となると手動での作業は、とても大変です。VBAを使って集めたファイルをひとつのファイル（ブック）に纏める方法を使うと簡単に纏めることができますので、そのプログラムの作成方法を説明したいと思います。

●プログラム説明　（サンプル①）

下記のプログラムは、EXCELファイルでアンケートを配布して、そのアンケートに記入してもらった複数ファイルを一つのフォルダーに集めて、その集めたファイルを一つのブックに集計するプログラムです。詳細については、下図を参照して下さい。

Sub アンケートファイルの取り込み処理()
        
    Dim Button, T, I, L As Integer
    Dim OpenExcelFileName, ExcelFileName, ExcelFilePath, FileName As String
    Dim Kaitou(12) As String
     
    Application.DisplayAlerts = False  '確認メッセージを無効化します。
    
    T = 5
    
    Button = MsgBox("アンケートファイル取込処理を行いますか？", vbYesNo + vbQuestion, "確認")
    If Button = vbYes Then
            
            OpenExcelFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")  'ダイアログを表示取り込むフォルダーにあるファイルを選択します。
            
            If OpenExcelFileName <> "False" Then
                ExcelFileName = Dir(OpenExcelFileName)  '指定したファイルパスからファイル名を代入します。
                ExcelFilePath = Replace(OpenExcelFileName, ExcelFileName, "")  '指定したファイルパスを指定します。（ファイルパスからファイル名を取り除く）
                        
                MsgBox ExcelFilePath & "この選択フォルダからデータを読込み込みます。"
            Else
                MsgBox "キャンセルされました"
                Exit Sub  'キャンセルでプログラムを終了します。
                
            End If
        
            FileName = Dir(ExcelFilePath & "*.xls?")  '指定したフォルダーから一件目のEXCELファイルを指定します。

            
            Do While FileName <> ""    '読み込むファイルがなくなるまで繰り返す。
                Workbooks.Open FileName:=ExcelFilePath & FileName, ReadOnly:=True, UpdateLinks:=0
                '
                
                '※０１-----------------------------------(読み込んだアンケートファイルの処理ここから)
                
                Sheets("アンケート").Select    'アンケートのシートを選択
                
                L = 0  '配列の0番からの指定
                
                For I = 4 To 14
                
                    Kaitou(L) = Cells(I, "C") 'C列のC4～C14のデータをkaitou配列に入れます。
                
                    L = L + 1     '配列の番号を加算する（次の配列に移す）
                    
                Next I
                
                ActiveWindow.Close  '読み込んだアンケートファイルと閉じます。
                
                '※０1-----------------------------------(読み込んだアンケートファイルの処理ここまで)
                 
                 
                '※０２----------------------------------(アンケート集計のファイル処理ここから）
                
                Sheets("結果一覧").Select      '結果一覧のシートを選択
            
                
                L = 0  '配列の0番からの指定
                
                For I = 1 To 12  'A列からK列まで繰り返す。
                
                    Cells(T, I) = Kaitou(L)  '配列dデータから結果一覧に転記する。
                    
                    L = L + 1  '配列の番号を加算する（次の配列に移す）
                    
                Next I
                
                Cells(T, "L") = "=SUM(G" & T & ":K" & T & ")" '列の結果合計にSUM関数を代入して合計を計算します。
  
                
                FileName = Dir() '次のファイルを指定する。
               
                T = T + 1  '結果一覧に転記する行を＋１加算する。
                 
                '※０２----------------------------------(アンケート集計のファイル処理ここまで）
            Loop
            
            Range("B1") = T - 5  '読込件数をB１に転記する。
            
                
            MsgBox "ファイル数" & T - 5 & "件　取り込みました。"  '読込件数をMsgBoxで表示
    Else
        MsgBox "処理を中断します"
    End If
    
    Application.DisplayAlerts = True  '確認メッセージを有効化します。
    
End Sub

Sub アンケートファイルの取り込み処理()

Dim Button, T, I, L As Integer

Dim OpenExcelFileName, ExcelFileName, ExcelFilePath, FileName As String

Dim Kaitou(12) As String

Application.DisplayAlerts = False '確認メッセージを無効化します。

T = 5

Button = MsgBox("アンケートファイル取込処理を行いますか？", vbYesNo + vbQuestion, "確認")

If Button = vbYes Then

OpenExcelFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") 'ダイアログを表示取り込むフォルダーにあるファイルを選択します。

If OpenExcelFileName <> "False" Then

ExcelFileName = Dir(OpenExcelFileName) '指定したファイルパスからファイル名を代入します。

ExcelFilePath = Replace(OpenExcelFileName, ExcelFileName, "") '指定したファイルパスを指定します。（ファイルパスからファイル名を取り除く）

MsgBox ExcelFilePath & "この選択フォルダからデータを読込み込みます。"

Else

MsgBox "キャンセルされました"

Exit Sub 'キャンセルでプログラムを終了します。

End If

FileName = Dir(ExcelFilePath & "*.xls?") '指定したフォルダーから一件目のEXCELファイルを指定します。

Do While FileName <> "" '読み込むファイルがなくなるまで繰り返す。

Workbooks.Open FileName:=ExcelFilePath & FileName, ReadOnly:=True, UpdateLinks:=0

'※０１-----------------------------------(読み込んだアンケートファイルの処理ここから)

Sheets("アンケート").Select 'アンケートのシートを選択

L = 0 '配列の0番からの指定

For I = 4 To 14

Kaitou(L) = Cells(I, "C") 'C列のC4～C14のデータをkaitou配列に入れます。

L = L + 1 '配列の番号を加算する（次の配列に移す）

Next I

ActiveWindow.Close '読み込んだアンケートファイルと閉じます。

'※０1-----------------------------------(読み込んだアンケートファイルの処理ここまで)

'※０２----------------------------------(アンケート集計のファイル処理ここから）

Sheets("結果一覧").Select '結果一覧のシートを選択

L = 0 '配列の0番からの指定

For I = 1 To 12 'A列からK列まで繰り返す。

Cells(T, I) = Kaitou(L) '配列dデータから結果一覧に転記する。

L = L + 1 '配列の番号を加算する（次の配列に移す）

Next I

Cells(T, "L") = "=SUM(G" & T & ":K" & T & ")" '列の結果合計にSUM関数を代入して合計を計算します。

FileName = Dir() '次のファイルを指定する。

T = T + 1 '結果一覧に転記する行を＋１加算する。

'※０２----------------------------------(アンケート集計のファイル処理ここまで）

Loop

Range("B1") = T - 5 '読込件数をB１に転記する。

MsgBox "ファイル数" & T - 5 & "件　取り込みました。" '読込件数をMsgBoxで表示

Else

MsgBox "処理を中断します"

End If

Application.DisplayAlerts = True '確認メッセージを有効化します。

End Sub

●実行前～実行後　※プログラム実行後、下記の順番で実行されます。
①アンケートファイルを実行するか確認します。
②ダイアログボックスが表示されて、アンケート結果が保存されているフォルダーのファイルを指定します。
③「開く」をクリックして、選択されたファイルのフォルダー内全てのファイルを読み込みます。
④読み込んだファイルを一件ずつ結果一覧に反映されます。
⑤最後に、取り込み件数（読み込んだ件数）が表示されて完了。