【複数ブック、アンケート、集計】【エクセル2013,VBA】

アンケートをエクセルで作成し、とりまとめ集計するためののコード。

なるべく汎用的に利用できるように、集計範囲をダイアログボックスで指定できるようにしています。

前提としては

・集計するブックの構成（回答の場所）は全て同じアドレスのセル

・アンケート結果は各ブックの1枚目のシートに記載する

・アンケートのブックは複数指定可

==================================

Sub アンケート集計()

Dim i As Long, j As Long, k As Long, GyoN As Long, tst As String, CellA As String, SN As String
Dim buf As Range, TCell As Range, arr1() As String

Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
SN = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name


'Step1:集計するセルの指定を行う
With Application.FileDialog(msoFileDialogOpen)
.Title = "まずは集計するセルを指定します。" & Chr(13) & "どれでもよいので集計したいファイルをひとつ開いてください。"
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Show

Workbooks.Open Filename:=.SelectedItems(1)
tst = ActiveWorkbook.Name
Set buf = Application.InputBox(prompt:="集計したいセルを選択してください（+ctrで複数選択可）", Type:=8)

ReDim arr1(1 To buf.Cells.Count) As String

i = 1
'セルのアドレスを配列に格納と同時にアドレスを記録
For Each TCell In buf
arr1(i) = TCell.Address
ThisWorkbook.Sheets(SN).Cells(1, i) = arr1(i)

i = i + 1
Next


Workbooks(tst).Close SaveChanges:=False

End With


'Step2:集計
GyoN = 2
With Application.FileDialog(msoFileDialogOpen)
.Title = "集計したいファイルを選択してください（+ctrで複数選択可）"

'複数指定可

.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = True
.Show


'順番にファイルを開き、step1で指定したセルをシートに書き出していく
For i = 1 To .SelectedItems.Count

Workbooks.Open Filename:=.SelectedItems(i)
tst = ActiveWorkbook.Name

For k = 1 To UBound(arr1)
'シートは一枚目のみ利用する。2枚目以降は無視される。

’追加したシートに書き出し
ThisWorkbook.Sheets(SN).Cells(GyoN, k) = Workbooks(tst).Sheets(1).Range(arr1(k))

Next

GyoN = GyoN + 1
Workbooks(tst).Close SaveChanges:=False
Next

End With

End Sub