'画面のちらつきを防止する
    Application.ScreenUpdating = False

    'プログラムに必要な変数を宣言する（削除しない）
    Dim path As String                              'ファイルパス
    Dim filename As String                          'ファイル名
    Dim answerWB As Workbook                        '回答ワークブック名
    Dim answerQNo As String                         '回答ワークブック（集計対象になる質問番号）
    Dim answerVal As String                         '回答ワークブック（質問に対する回答）
    Dim answerCellRowNo As Long                     '回答ワークブックの現在集計している行数
    Dim totalWB As Workbook                         '集計ワークブック名
    Dim totalQNo As String                          '集計ワークブック（集計対象になる質問番号）
    Dim totalVal As String                          '集計ワークブック（質問に対する回答）
    Dim totalCnt As Long                            '集計ワークブック（現在の回答数）
    Dim totalCellRowNo As Long                      '集計ワークブックの現在集計している行数
    Dim numPeople As Long                           '集計人数
    
    '【変更OK】回答Excelファイルを保存しているフォルダを指定する（""内を修正する）
    path = "c:\data\"
    
    '集計人数初期化
    numPeople = 0
       
    '集計ブックの情報を記録する
    Set totalWB = ThisWorkbook

    '集計ブックの初期化処理
    With totalWB.Worksheets("集計")
        
        '集計ブックの更新日を作成する
        .Range("B3") = Date
        
        '以前の集計人数が存在すれば、削除
        .Range("C7").Select
        .Range(Selection, Selection.End(xlDown)).Select
        Selection.ClearContents
        
    End With
         
    '保存したフォルダを指定して、ファイル名を１つ取り出す
    filename = Dir(path)
    
    'フォルダに含まれるExcelファイルをすべて取得する
    '１つもファイルがなければ、即時終了する。
    Do While Len(filename) > 0
    
        '拡張子.xlsであるときのみ、集計処理を行う
        If Right(filename, 4) = ".xls" Then
            
            '読み込んだ回答ブックを開いて、回答ブックの情報を記録する
            Set answerWB = Workbooks.Open(path & filename)
            
            '選択した回答ブックから処理開始行を選択する
            '処理開始位置を5行目とする
            answerCellRowNo = 5
            answerWB.Activate
            answerWB.Worksheets("アンケート").Cells(answerCellRowNo, 1).Activate
            
            '回答ブックの質問番号、回答を取得する
            answerQNo = ActiveCell.Value
            answerVal = ActiveCell.Offset(0, 5).Value

            '回答ブックの質問番号がなければ、ループを抜ける
            Do Until answerQNo = ""
            
                '集計ブックを選択
                totalCellRowNo = 7
                
                '回答ブックの質問番号と回答が、集計ブックに存在するか調べる
                Do
                    
                    totalWB.Activate
                    totalWB.Worksheets("集計").Cells(totalCellRowNo, 1).Activate
                    
                    '次の既存データを読み込む
                    '集計ブックの質問番号、回答を取得する
                    totalQNo = ActiveCell.Value
                    totalVal = ActiveCell.Offset(0, 1)
                    totalCnt = ActiveCell.Offset(0, 2)
                    
                    '集計ブックに該当データが見つからなかったときの追加処理
                    If (totalQNo = "") And (totalVal = "") Then
                
                        '回答ブックのデータを集計ブックに挿入
                        ActiveCell.Value = answerQNo
                        ActiveCell.Offset(0, 1) = answerVal
                        ActiveCell.Offset(0, 2) = 1
                        
                    ElseIf (answerQNo = totalQNo) And (answerVal = totalVal) Then
                        
                        '回答ブックと集計ブックが一致したら、回答数をカウント
                        ActiveCell.Offset(0, 2) = totalCnt + 1
                    
                    End If
                    
                    totalCellRowNo = totalCellRowNo + 1
                    
                Loop Until ((totalQNo = "") And (totalVal = "")) Or ((answerQNo = totalQNo) And (answerVal = totalVal))
                                
                '次の質問のための準備
                'アクティブセルを下方に１移動する
                answerCellRowNo = answerCellRowNo + 1
                answerWB.Activate
                answerWB.Worksheets("アンケート").Cells(answerCellRowNo, 1).Activate
                
                '回答ブックの質問番号、回答を取得する
                answerQNo = ActiveCell.Value
                answerVal = ActiveCell.Offset(0, 5).Value
            
            Loop
            
            '回答ブックを閉じる
            answerWB.Close
            
            '集計人数を増加
            numPeople = numPeople + 1
            
        End If
        
        '次のファイルを読む
        filename = Dir()
    
    Loop
    
    '集計ブックの集計人数を更新する
    totalWB.Activate
    totalWB.Worksheets("集計").Range("B4") = numPeople
    totalWB.Worksheets("集計").Range("B4").Select
    
    '作業領域の開放
    Set answerWB = Nothing
    Set totalWB = Nothing
    
    '画面のちらつきを防止する
    Application.ScreenUpdating = True