下記のプログラムは、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
