複数ブックに分散した回答を1シートに
はじめに
Excelでテストやアンケートを作成し、複数人に配布・回収するシーンは多いかと思います。
受講者A.xlsx
受講者B.xlsx
受講者C.xlsx
...
しかし、いざ採点や集計をしようとすると、「全員分の問1シートのC5セルの回答を一覧で見比べたい…」と思っても、ブックを一つひとつ開いてコピペする作業が発生し、地獄を見ます。
この記事では、そんなコピペ地獄から解放されるため、指定したフォルダ内の全Excelブックから、指定したセルの値だけを抜き出して一覧表にするVBAツールを紹介します。
ツールのできあがりイメージ
image.png
このツールは、以下のような「集約シート」を自動で作成します。
模範解答の横に、各ファイル（「田中」「長瀬」…）の回答がズラッと並ぶため、自由記述問題の採点や比較が非常に楽になります。
ツールの前提条件
このツールは、以下の2種類のファイルで構成されます。
- 集約用ブック（マクロ実行ブック）
回答収集ツール.xlsm など、マクロを保存するブックです。
このブックに、収集結果を書き出すためのシート（デフォルト名は 回答収集）を準備します。
A列: 回答ブックの「どのシート名」から読み取るか
B列: 回答ブックの「どのセル番地」から読み取るか
C列: 模範解答（※VBAでは使いませんが、採点時に便利です）
2. 回答用ブック（収集対象）
田中.xlsx 長瀬.xlsx のように、収集対象となる回答済みのExcelファイルです。
これらは、1つのフォルダにまとめておいてください。
ツールの特徴：settingシートによる高い保守性
このツールの特徴は、VBAコードを直接編集しなくても設定変更ができる点です。
「集約シート名が 回答収集 じゃないんだよな…」
「見出しは3行目からにしたい…」
といった変更に対応するため、settingシート（マクロで自動生成）で主要な設定を管理するようにしています。
設定項目 値 説明
回答収集シート名 回答収集 結果を書き出すシートの名前
見出し行番号 2 ファイル名（田中、長瀬...）を書き出す行
データ開始行番号 3 回答の読み取り/書き込みを開始する行
回答書き込み開始列 D D列から回答を書き出す
エラー時表示 取得失敗 シートやセルが見つからない時の表示
ツールの使い方
コードの貼り付け
ExcelでVBAエディタ（Alt + F11）を開き、「挿入」>「標準モジュール」を選択します。
後述する2つのVBAコード（run_Settingシート初期作成 と main_回答収集実行）を貼り付けます。
settingシートの作成
run_Settingシート初期作成 のマクロを実行します。
ブックの一番左に setting シートが自動生成されます。必要に応じてB列の値を修正してください。
回答収集の実行
main_回答収集実行 のマクロを実行します。
フォルダ選択画面が表示されるので、回答用ブック（田中.xlsxなど）が格納されたフォルダを選択します。
完了
処理が完了すると、回答収集シート（またはsettingで指定したシート）に結果が自動で転記されます。
VBAコード全体
標準モジュールに以下のコードを貼り付けてください。
- settingシート作成用コード
（※先にこちらを実行してください、設定シートを作成します。）
image.png
Option Explicit
'==========================================================
' モジュール名：mod_回答収集
' 機能概要 ：複数のExcelブックから回答を収集し、比較表を作成する
'==========================================================
'----------------------------------------------------------
' run_Settingシート初期作成
' 機能概要 : 本ツールで参照する設定値を管理する「setting」シートを作成する
' 引数 : なし
' 戻り値 : なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Public Sub run_Settingシート初期作成()
On Error GoTo ERR_HANDLER
Dim ws_設定 As Worksheet
Dim bln_存在チェック As Boolean
Dim obj_シート As Object
' settingシートの存在をチェックする
bln_存在チェック = False
For Each obj_シート In ThisWorkbook.Worksheets
If obj_シート.Name = "setting" Then
bln_存在チェック = True
Exit For
End If
Next obj_シート
' 存在しない場合のみシートを作成する
If bln_存在チェック = False Then
Set ws_設定 = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
ws_設定.Name = "setting"
' 設定項目のヘッダーとデフォルト値を書き込む
With ws_設定
.Range("A1").Value = "設定項目"
.Range("B1").Value = "値"
.Range("A2").Value = "回答収集シート名"
.Range("B2").Value = "回答収集"
.Range("A3").Value = "見出し列番号"
.Range("B3").Value = 2
.Range("A4").Value = "データ開始列番号"
.Range("B4").Value = 3
.Range("A5").Value = "回答書き込み開始行"
.Range("B5").Value = 3
.Range("A6").Value = "エラー時表示"
.Range("B6").Value = "取得失敗"
' 見た目を調整する
.Columns("A:B").AutoFit
.Range("A1:B1").Font.Bold = True
End With
MsgBox "「setting」シートを作成しました。初期設定を確認してください。", vbInformation
End If
Exit Sub
ERR_HANDLER:
' エラー処理を行う
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "設定シートの作成中にエラーが発生しました。" & vbCrLf & vbCrLf & _
"エラー番号: " & Err.Number & vbCrLf & _
"エラー内容: " & Err.Description, vbCritical, "エラー"
End Sub
2. 回答収集メイン処理コード
'----------------------------------------------------------
' main_回答収集実行
' 機能概要 : 指定フォルダ内の全Excelブックから回答を収集し、比較表を作成する
' 引数 : なし
' 戻り値 : なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Public Sub main_回答収集実行()
On Error GoTo ERR_HANDLER
' 定数を宣言する
Const STR_設定シート名 As String = "setting"
' オブジェクト変数を宣言する
Dim ws_設定 As Worksheet
Dim ws_回答収集 As Worksheet
Dim wb_回答ブック As Workbook
Dim fld_ダイアログ As FileDialog
' 設定値を格納する変数を宣言する
Dim str_回答収集シート名 As String
Dim lng_見出し列 As Long
Dim lng_データ開始列 As Long
Dim lng_書き込み開始行 As Long
Dim str_エラー時表示 As String
' 処理用変数を宣言する
Dim str_フォルダパス As String
Dim str_ファイル名 As String
Dim lng_書き込み行 As Long
Dim lng_読み込み列 As Long
Dim lng_最終列 As Long
Dim str_読み込みシート As String
Dim str_読み込みセル As String
Dim var_取得値 As Variant
' settingシートの存在を確認する
On Error Resume Next
Set ws_設定 = ThisWorkbook.Worksheets(STR_設定シート名)
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "「setting」シートが見つかりません。" & vbCrLf & _
"「run_Settingシート初期作成」を実行してシートを作成してください。", vbCritical
Exit Sub
End If
On Error GoTo ERR_HANDLER ' ここで標準エラーハンドラに戻す
' 設定値をsettingシートから読み込む
With ws_設定
str_回答収集シート名 = .Range("B2").Value
lng_見出し列 = .Range("B3").Value
lng_データ開始列 = .Range("B4").Value
lng_書き込み開始行 = .Range("B5").Value
str_エラー時表示 = .Range("B6").Value
End With
' 回答収集シートの存在をチェックする
On Error Resume Next
Set ws_回答収集 = ThisWorkbook.Worksheets(str_回答収集シート名)
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "設定シートで指定された「" & str_回答収集シート名 & "」シートが見つかりません。", vbCritical
Exit Sub
End If
On Error GoTo ERR_HANDLER ' 標準エラーハンドラに戻す
' フォルダ選択ダイアログを表示する
Set fld_ダイアログ = Application.FileDialog(msoFileDialogFolderPicker)
fld_ダイアログ.Title = "回答ファイルが保存されているフォルダを選択してください"
If fld_ダイアログ.Show = False Then
MsgBox "処理がキャンセルされました。", vbInformation
Exit Sub
End If
str_フォルダパス = fld_ダイアログ.SelectedItems(1) & Application.PathSeparator
' 画面更新を停止して既存データをクリアする
Application.ScreenUpdating = False
With ws_回答収集
.Range(.Cells(lng_書き込み開始行, lng_データ開始列), .Cells(.Rows.Count, .Columns.Count)).ClearContents
End With
' ファイル巡回処理を開始する
lng_書き込み行 = lng_書き込み開始行
str_ファイル名 = Dir(str_フォルダパス & "*.xls*")
Do While str_ファイル名 <> ""
' 自分自身のブックを除外する
If str_ファイル名 <> ThisWorkbook.Name Then
' 回答ブックを読み取り専用で開く
Set wb_回答ブック = Workbooks.Open(str_フォルダパス & str_ファイル名, ReadOnly:=True)
' 見出し列にブック名を書き込む
ws_回答収集.Cells(lng_書き込み行, lng_見出し列).Value = wb_回答ブック.Name
' 収集シートのA列を基準に列を巡回する
lng_最終列 = ws_回答収集.Cells(1, ws_回答収集.Columns.Count).End(xlToLeft).Column
For lng_読み込み列 = lng_データ開始列 To lng_最終列
str_読み込みシート = ws_回答収集.Cells(1, lng_読み込み列).Value
str_読み込みセル = ws_回答収集.Cells(2, lng_読み込み列).Value
' セルの値を取得する（エラーハンドリング付き）
On Error Resume Next
var_取得値 = wb_回答ブック.Worksheets(str_読み込みシート).Range(str_読み込みセル).Value
If Err.Number <> 0 Then
ws_回答収集.Cells(lng_書き込み行, lng_読み込み列).Value = str_エラー時表示
Err.Clear
Else
ws_回答収集.Cells(lng_書き込み行, lng_読み込み列).Value = var_取得値
End If
On Error GoTo ERR_HANDLER ' 標準エラーハンドラに戻す
Next lng_読み込み列
' 回答ブックを閉じる
wb_回答ブック.Close SaveChanges:=False
' 次の書き込み行に移動する
lng_書き込み行 = lng_書き込み行 + 1
End If
' 次のファイルを取得する
str_ファイル名 = Dir()
Loop
' 処理を完了する
Application.ScreenUpdating = True
ws_回答収集.Activate
ws_回答収集.Cells(1, 1).Select
MsgBox "回答の収集が完了しました。", vbInformation
Exit Sub
ERR_HANDLER:
' エラー処理
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Dim str_エラーメッセージ As String
str_エラーメッセージ = "エラーが発生しました。" & vbCrLf & vbCrLf & _
"エラー番号: " & Err.Number & vbCrLf & _
"エラー内容: " & Err.Description & vbCrLf & vbCrLf & _
"処理を中断します。"
MsgBox str_エラーメッセージ, vbCritical, "エラー"
' 開いているブックがあれば閉じる（処理中断時にファイルを開きっぱなしにしないため）
On Error Resume Next
If Not wb_回答ブック Is Nothing Then
wb_回答ブック.Close SaveChanges:=False
End If
On Error GoTo 0
End Sub
コードのポイント解説
1. フォルダ選択ダイアログ
Application.FileDialog(msoFileDialogFolderPicker) を使うことで、ユーザーに視覚的にフォルダを選択してもらうことができます。
Set fld_ダイアログ = Application.FileDialog(msoFileDialogFolderPicker)
If fld_ダイアログ.Show = False Then Exit Sub ' キャンセル時
str_フォルダパス = fld_ダイアログ.SelectedItems(1) & Application.PathSeparator
2. フォルダ内のファイル巡回
Dir関数を使って、指定したフォルダ内のExcelファイル（.xls*）を順番に処理します。
str_ファイル名 = Dir(str_フォルダパス & "*.xls*")
Do While str_ファイル名 <> ""
' ... ファイル処理 ...
str_ファイル名 = Dir() ' 次のファイルを取得
Loop
3. 動的なエラーハンドリング
このツールの肝です。回答ブック側に「指定したシート名が存在しない」「セル番地が間違っている」といった不備があっても、マクロがエラーで停止しないように制御しています。
値を取得する直前で On Error Resume Next を宣言し、エラーを意図的に無視させます。
値の取得が終わったら、Err.Number をチェックしてエラーが発生していたか（0以外か）を判定し、発生していた場合は setting シートで指定したエラー表示（例: "取得失敗"）を書き込んでいます。
' セルの値を取得する（エラーハンドリング付き）
On Error Resume Next
var_取得値 = wb_回答ブック.Worksheets(str_読み込みシート).Range(str_読み込みセル).Value
If Err.Number <> 0 Then
ws_回答収集.Cells(lng_読み込み行, lng_書き込み列).Value = str_エラー時表示
Err.Clear
Else
ws_回答収集.Cells(lng_読み込み行, lng_書き込み列).Value = var_取得値
End If
' ★標準のエラーハンドラに戻す（忘れると全てのエラーが無視される）
On Error GoTo ERR_HANDLER
おわりに
単純なコピペ作業はVBAに任せて、人間は採点や分析といった本来の業務に集中しましょう。
自由記述式のテスト採点や、アンケート集計などでぜひご活用ください。
おまけで縦書式の場合も掲載します。
Option Explicit
'==========================================================
' モジュール名：mod_回答収集
' 機能概要 ：複数のExcelブックから回答を収集し、比較表を作成する
'==========================================================
'----------------------------------------------------------
' run_Settingシート初期作成
' 機能概要 : 本ツールで参照する設定値を管理する「setting」シートを作成する
' 引数 : なし
' 戻り値 : なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Public Sub run_Settingシート初期作成()
On Error GoTo ERR_HANDLER
Dim ws_設定 As Worksheet
Dim bln_存在チェック As Boolean
Dim obj_シート As Object
' settingシートの存在をチェックする
bln_存在チェック = False
For Each obj_シート In ThisWorkbook.Worksheets
If obj_シート.Name = "setting" Then
bln_存在チェック = True
Exit For
End If
Next obj_シート
' 存在しない場合のみシートを作成する
If bln_存在チェック = False Then
Set ws_設定 = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
ws_設定.Name = "setting"
' 設定項目のヘッダーとデフォルト値を書き込む
With ws_設定
.Range("A1").Value = "設定項目"
.Range("B1").Value = "値"
.Range("C1").Value = "説明"
.Range("A2").Value = "回答収集シート名"
.Range("B2").Value = "回答収集"
.Range("C2").Value = "回答を収集・集計するシートの名前"
.Range("A3").Value = "見出し列番号"
.Range("B3").Value = 2
.Range("C3").Value = "見出しが記載されている列番号（B=2）"
.Range("A4").Value = "データ開始列番号"
.Range("B4").Value = 3
.Range("C4").Value = "回答データが開始する列番号（C=3）"
.Range("A5").Value = "回答書き込み開始行"
.Range("B5").Value = 3
.Range("C5").Value = "実際の回答内容を書き込む先頭行番号（3行目から書き込み）"
.Range("A6").Value = "エラー時表示"
.Range("B6").Value = "取得失敗"
.Range("C6").Value = "データ取得エラー時に表示する文字列"
.Range("A7").Value = "解説列番号"
.Range("B7").Value = 1 ' デフォルト値: A列
.Range("C7").Value = "解説や質問項目の列番号（A=1）"
' 見た目を調整する
.Columns("A:B").AutoFit
.Range("A1:B1").Font.Bold = True
End With
MsgBox "「setting」シートを作成しました。初期設定を確認してください。", vbInformation
End If
Exit Sub
ERR_HANDLER:
' エラー処理を行う
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "設定シートの作成中にエラーが発生しました。" & vbCrLf & vbCrLf & _
"エラー番号: " & Err.Number & vbCrLf & _
"エラー内容: " & Err.Description, vbCritical, "エラー"
End Sub
'----------------------------------------------------------
' main_回答収集実行
' 機能概要 : 指定フォルダ内の全Excelブックから回答を収集し、比較表を作成する
' 引数 : なし
' 戻り値 : なし
' YYYY/MM/DD 名前
'----------------------------------------------------------
Public Sub main_回答収集実行()
On Error GoTo ERR_HANDLER
' 定数を宣言する
Const STR_設定シート名 As String = "setting"
' オブジェクト変数を宣言する
Dim ws_設定 As Worksheet
Dim ws_回答収集 As Worksheet
Dim wb_回答ブック As Workbook
Dim fld_ダイアログ As FileDialog
' 設定値を格納する変数を宣言する
Dim str_回答収集シート名 As String
Dim lng_見出し列 As Long
Dim lng_データ開始列 As Long
Dim lng_書き込み開始行 As Long
Dim str_エラー時表示 As String
' 処理用変数を宣言する
Dim str_フォルダパス As String
Dim str_ファイル名 As String
Dim lng_書き込み行 As Long
Dim lng_読み込み列 As Long
Dim lng_最終列 As Long
Dim str_読み込みシート As String
Dim str_読み込みセル As String
Dim var_取得値 As Variant
' settingシートの存在を確認する
On Error Resume Next
Set ws_設定 = ThisWorkbook.Worksheets(STR_設定シート名)
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "「setting」シートが見つかりません。" & vbCrLf & _
"「run_Settingシート初期作成」を実行してシートを作成してください。", vbCritical
Exit Sub
End If
On Error GoTo ERR_HANDLER ' ここで標準エラーハンドラに戻す
' 設定値をsettingシートから読み込む
With ws_設定
str_回答収集シート名 = .Range("B2").Value
lng_見出し列 = .Range("B3").Value
lng_データ開始列 = .Range("B4").Value
lng_書き込み開始行 = .Range("B5").Value
str_エラー時表示 = .Range("B6").Value
End With
' 回答収集シートの存在をチェックする
On Error Resume Next
Set ws_回答収集 = ThisWorkbook.Worksheets(str_回答収集シート名)
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "設定シートで指定された「" & str_回答収集シート名 & "」シートが見つかりません。", vbCritical
Exit Sub
End If
On Error GoTo ERR_HANDLER ' 標準エラーハンドラに戻す
' フォルダ選択ダイアログを表示する
Set fld_ダイアログ = Application.FileDialog(msoFileDialogFolderPicker)
fld_ダイアログ.Title = "回答ファイルが保存されているフォルダを選択してください"
If fld_ダイアログ.Show = False Then
MsgBox "処理がキャンセルされました。", vbInformation
Exit Sub
End If
str_フォルダパス = fld_ダイアログ.SelectedItems(1) & Application.PathSeparator
' 画面更新を停止して既存データをクリアする
Application.ScreenUpdating = False
With ws_回答収集
.Range(.Cells(lng_書き込み開始行, lng_データ開始列), .Cells(.Rows.Count, .Columns.Count)).ClearContents
End With
' ファイル巡回処理を開始する
lng_書き込み行 = lng_書き込み開始行
str_ファイル名 = Dir(str_フォルダパス & "*.xls*")
Do While str_ファイル名 <> ""
' 自分自身のブックを除外する
If str_ファイル名 <> ThisWorkbook.Name Then
' 回答ブックを読み取り専用で開く
Set wb_回答ブック = Workbooks.Open(str_フォルダパス & str_ファイル名, ReadOnly:=True)
' 見出し列にブック名を書き込む
ws_回答収集.Cells(lng_書き込み行, lng_見出し列).Value = wb_回答ブック.Name
' 収集シートのA列を基準に列を巡回する
lng_最終列 = ws_回答収集.Cells(1, ws_回答収集.Columns.Count).End(xlToLeft).Column
For lng_読み込み列 = lng_データ開始列 To lng_最終列
str_読み込みシート = ws_回答収集.Cells(1, lng_読み込み列).Value
str_読み込みセル = ws_回答収集.Cells(2, lng_読み込み列).Value
' セルの値を取得する（エラーハンドリング付き）
On Error Resume Next
var_取得値 = wb_回答ブック.Worksheets(str_読み込みシート).Range(str_読み込みセル).Value
If Err.Number <> 0 Then
ws_回答収集.Cells(lng_書き込み行, lng_読み込み列).Value = str_エラー時表示
Err.Clear
Else
ws_回答収集.Cells(lng_書き込み行, lng_読み込み列).Value = var_取得値
End If
On Error GoTo ERR_HANDLER ' 標準エラーハンドラに戻す
Next lng_読み込み列
' 回答ブックを閉じる
wb_回答ブック.Close SaveChanges:=False
' 次の書き込み行に移動する
lng_書き込み行 = lng_書き込み行 + 1
End If
' 次のファイルを取得する
str_ファイル名 = Dir()
Loop
' 処理を完了する
Application.ScreenUpdating = True
ws_回答収集.Activate
ws_回答収集.Cells(1, 1).Select
MsgBox "回答の収集が完了しました。", vbInformation
Exit Sub
ERR_HANDLER:
' エラー処理
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Dim str_エラーメッセージ As String
str_エラーメッセージ = "エラーが発生しました。" & vbCrLf & vbCrLf & _
"エラー番号: " & Err.Number & vbCrLf & _
"エラー内容: " & Err.Description & vbCrLf & vbCrLf & _
"処理を中断します。"
MsgBox str_エラーメッセージ, vbCritical, "エラー"
' 開いているブックがあれば閉じる（処理中断時にファイルを開きっぱなしにしないため）
On Error Resume Next
If Not wb_回答ブック Is Nothing Then
wb_回答ブック.Close SaveChanges:=False
End If
On Error GoTo 0
End Sub