はじめに

「毎月、数十個のアンケートファイルを手作業で集計している」という業務担当者からのご相談は非常に多いです。

本記事では、フォルダ内に散在する複数のExcelファイルをボタンひとつで自動集計するVBAの実装方法を解説します。実際に弊社が開発・納品したシステムをベースにした実践的な内容です。

解決する課題

フォルダ内に30〜50個のアンケートExcelファイルがある
毎月、各ファイルを手作業で開いてデータをコピーしている
集計シートへの転記ミスが発生する
作業に毎月まる1日以上かかっている

完成イメージ

【フォルダ構成】
C:\anketo\
├── anketo_001.xlsx
├── anketo_002.xlsx
├── anketo_003.xlsx
│ ...
└── anketo_050.xlsx
 
【集計ファイル】
集計マスター.xlsm ← このファイルにVBAを実装
├── Sheet1（集計結果シート）
└── Module1（VBAコード）

ボタンをクリックすると、指定フォルダ内の全Excelファイルを自動で読み込み、集計シートに転記します。

実装コード

基本構造：フォルダ内ファイルの一括読み込み

Sub 一括集計()
 
Dim folderPath As String
Dim fileName As String
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim wsDst As Worksheet
Dim lastRow As Long
Dim dstRow As Long
 
' 集計先シートを指定
Set wsDst = ThisWorkbook.Sheets("集計結果")
 
' 集計先をクリア（ヘッダー行は残す）
wsDst.Rows("2:" & wsDst.Rows.Count).ClearContents
 
' 集計先の書き込み開始行
dstRow = 2
 
' 対象フォルダのパスを指定
folderPath = "C:\anketo\"
 
' フォルダ内の最初のxlsxファイルを取得
fileName = Dir(folderPath & "*.xlsx")
 
' ファイルがなくなるまでループ
Do While fileName <> ""
 
' ファイルを画面更新なしで開く（高速化）
Application.ScreenUpdating = False
Set wbSrc = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
Set wsSrc = wbSrc.Sheets(1)
 
' データの最終行を取得
lastRow = wsSrc.Cells(wsSrc.Rows.Count, 1).End(xlUp).Row
 
' 2行目以降（ヘッダーを除く）のデータをコピー
If lastRow >= 2 Then
wsSrc.Range("A2:E" & lastRow).Copy _
Destination:=wsDst.Cells(dstRow, 1)
dstRow = dstRow + (lastRow - 1)
End If
 
' ファイルを閉じる（保存しない）
wbSrc.Close SaveChanges:=False
 
' 次のファイルへ
fileName = Dir()
 
Loop
 
Application.ScreenUpdating = True
 
MsgBox "集計完了しました。" & Chr(13) & _
"集計件数：" & (dstRow - 2) & "件", vbInformation
 
End Sub

応用①：クロス集計の自動生成

集計後にPivotTableを自動生成するコードです。

Sub クロス集計作成()
 
    Dim wsDst    As Worksheet
    Dim wsPivot  As Worksheet
    Dim pc       As PivotCache
    Dim pt       As PivotTable
    Dim pf       As PivotField
    Dim lastRow  As Long
    Dim lastCol  As Long
    Dim dataRange As Range
 
    Set wsDst = ThisWorkbook.Sheets("集計結果")
 
    ' データ範囲を取得
    lastRow = wsDst.Cells(wsDst.Rows.Count, 1).End(xlUp).Row
    lastCol = wsDst.Cells(1, wsDst.Columns.Count).End(xlToLeft).Column
 
    ' データが2行以上ない場合は終了
    If lastRow < 2 Then
        MsgBox "集計データがありません。先に一括集計を実行してください。", vbExclamation
        Exit Sub
    End If
 
    Set dataRange = wsDst.Range(wsDst.Cells(1, 1), wsDst.Cells(lastRow, lastCol))
 
    ' ピボットシートが既にあれば削除して再作成
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("クロス集計").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
 
    Set wsPivot = ThisWorkbook.Sheets.Add(After:=wsDst)
    wsPivot.Name = "クロス集計"
 
    ' ピボットキャッシュを作成
    Set pc = ThisWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=dataRange)
 
    ' ピボットテーブルを作成
    Set pt = pc.CreatePivotTable( _
        TableDestination:=wsPivot.Cells(3, 1), _
        TableName:="クロス集計表")
 
    ' 行・列・値フィールドを設定
    With pt
        .PivotFields("部門").Orientation = xlRowField
        .PivotFields("年代").Orientation = xlColumnField
 
        ' AddDataFieldで追加・関数・名前を一括設定（名前変化によるエラーを防ぐ）
        Set pf = .AddDataField( _
            .PivotFields("Q3_総合評価"), "平均_総合評価", xlAverage)
        pf.NumberFormat = "0.0"
    End With
 
    ' タイトルを追加
    wsPivot.Cells(1, 1).Value = "部門×年代 クロス集計（Q3_総合評価 平均）"
    wsPivot.Cells(1, 1).Font.Bold = True
 
    MsgBox "クロス集計を作成しました。", vbInformation
 
End Sub

応用②：条件による自動色分け

集計結果のセルを値に応じて自動で色分けします。

Sub 自動色分け()
 
Dim wsDst As Worksheet
Dim lastRow As Long
Dim i As Long
Dim score As Double
Dim targetCol As Integer
 
Set wsDst = ThisWorkbook.Sheets("集計結果")
 
' 色分け対象の列番号（例：E列 = 5）
targetCol = 5
 
lastRow = wsDst.Cells(wsDst.Rows.Count, targetCol).End(xlUp).Row
 
For i = 2 To lastRow
 
' 空白セルはスキップ
If wsDst.Cells(i, targetCol).Value = "" Then GoTo Continue
 
score = CDbl(wsDst.Cells(i, targetCol).Value)
 
Select Case True
Case score >= 80 ' 80以上：緑
wsDst.Cells(i, targetCol).Interior.Color = RGB(144, 238, 144)
Case score >= 60 ' 60〜79：黄
wsDst.Cells(i, targetCol).Interior.Color = RGB(255, 255, 153)
Case Else ' 59以下：赤
wsDst.Cells(i, targetCol).Interior.Color = RGB(255, 153, 153)
End Select
 
Continue:
Next i
 
MsgBox "色分けが完了しました。", vbInformation
 
End Sub

ボタンへの割り当て

上記3つのマクロを順番に実行するメインマクロを作成し、シート上のボタンに割り当てます。

Sub メイン処理()
 
' 処理開始確認
If MsgBox("集計処理を開始します。よろしいですか？", _
vbYesNo + vbQuestion, "確認") = vbNo Then Exit Sub
 
' 1. 一括集計
Call 一括集計
 
' 2. クロス集計
Call クロス集計作成
 
' 3. 色分け
Call 自動色分け
 
MsgBox "すべての処理が完了しました。", vbInformation, "完了"
 
End Sub

実装時のポイント

1. 高速化のための設定

大量ファイルを処理する場合、以下の設定をメイン処理の前後に入れると処理速度が大幅に改善します。

' 処理前（高速化ON）
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
 
' 処理後（高速化OFF・元に戻す）
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

2. エラーハンドリング

ファイルが壊れていたり、想定外のフォーマットだったりした場合に備えてエラーハンドリングを追加します。

On Error GoTo ErrorHandler
 
' ～処理～
 
Exit Sub
 
ErrorHandler:
' エラー発生時はファイルを閉じて次へ進む
If Not wbSrc Is Nothing Then
wbSrc.Close SaveChanges:=False
End If
MsgBox "エラーが発生しました。" & Chr(13) & _
"ファイル名：" & fileName & Chr(13) & _
"エラー内容：" & Err.Description, vbExclamation
Resume Next

3. フォルダ選択ダイアログの実装

フォルダパスをコードに直書きせず、実行時に選択できるようにするとより使いやすくなります。

' フォルダ選択ダイアログ
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "集計対象フォルダを選択してください"
 
If fd.Show = True Then
folderPath = fd.SelectedItems(1) & "\"
Else
MsgBox "フォルダが選択されませんでした。", vbExclamation
Exit Sub
End If

実際の導入効果

今回ご紹介したコードをベースに開発したシステムの導入事例です。

項目	導入前	導入後
集計作業時間	約8時間／月	約10分／月
転記ミス	月2〜3件	ゼロ
集計ファイル数	30〜50件	変わらず
開発・納品期間	ー	約1ヶ月
開発費用	ー	10万円以下

まとめ

今回紹介したVBAの主なポイントは以下の通りです。

Dir() 関数でフォルダ内ファイルをループ処理
ScreenUpdating = False で高速化
PivotCacheでクロス集計を自動生成
Select Caseで条件色分けを自動化
FileDialogでフォルダ選択をUI化

「繰り返しの手作業」はVBAで自動化できるケースがほとんどです。ぜひ参考にしてみてください。

弊社について

株式会社エム・システムは岩手県盛岡市を開発拠点とするニアショア開発会社で、Excel/VBA開発実績100社以上・リピート率90%・本番稼働まで品質保証する会社です。

「自動化できるか試してみたい」「費用感を知りたい」という段階からご相談いただけます。
お見積りは無償です。