【複数のブックをひとつのブックにまとめる】【エクセル2013,VBA】

複数のブックをまとめるコード。例えばエクセルで作成した雛形やアンケートをメールで配り記入してもらい、その回答をひとつのブックにまとめたい場合に使用する。

以下コード

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

Sub シート集計()
Dim i As Long, tst As String, CellA As String

'シート内の特定のセルをシート名にしたい場合はCellAにアドレスを入れる。例：各シートのRange("A1")に名前や固有のIDが入っていてそれをシート名にしたい場合「CellA="A1"」とする。
CellA = ""

With Application.FileDialog(msoFileDialogOpen)
.Title = "統合したいエクセルファイルを選択（+ctr or +shiftで複数選択）"
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = True
.Show

For i = 1 To .SelectedItems.Count

'フルパスからファイル名を取得する。
tst = Dir(.SelectedItems(i))
'選んだブックを順に開く
Workbooks.Open Filename:=.SelectedItems(i)
'シートは「すべて」コピーされる。
Sheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'CellAが空欄でなければシート名を書き換える
If CellA <> "" Then
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Range(CellA)
End If

'ブックを閉じる。
Workbooks(tst).Close SaveChanges:=False

Next
End With

End Sub

Sub 特定シートの削除()
'おまけ。特定の名前のついているシートを削除する。
Dim SN As String, SC As Long
Application.DisplayAlerts = False
'↓の場合はSheetという文字が含まれるシートを削除
SN = "Sheet"
SC = Sheets.Count
For i = SC To 1 Step -1
If InStr(1, Sheets(i).Name, SN) > 0 Then
Sheets(i).Delete
End If
Next
Application.DisplayAlerts = True
End Sub

Sub シート削除All()
'Sheets(1)を除くすべてのシートを削除する。
On Error Resume Next
Dim SN As String, SC As Long
Application.DisplayAlerts = False
SC = Sheets.Count
For i = SC To 1 Step -1
Sheets(i).Delete
Next
Application.DisplayAlerts = True
End Sub