フォルダから全てのxlsファイルを読み込んで処理するVBAマクロ

EXCELで作られたアンケートがあって、集計がすごい手間どりそうだったので、
自動集計してみた。

• 前提

フォーマットをアンケート回答者に配布し、
意見を記入してもらう。
その後ファイルサーバーのある共有フォルダに提出してもらう。

フォーマットは以下のような形式

	A	B	C
1	Aついてのご意見	ここに意見を記入
2	Bついてのご意見	ここに意見を記入
3	Cついてのご意見	ここに意見を記入

これを自動で、
A.xls、B.xls、C.xlsというファイルを作成、それぞれ集計結果をまとめる。

• マクロ操作方法

1.回答済みアンケートがあるフォルダを選択する
2.集計結果を保存するフォルダを選択する

• マクロが格納されているExcelファイルにも質問一覧を記載しておく

• 以下コード

Option Explicit
Sub Summary() ' フォーマット集計

Const QUES_NO = 50 ' 50個の質問がある
Const READPOINT = "A2" ' A2から順に下に読む
Const STARTPOINT = "A2" ' ファイル作成時の結果格納開始場所

Dim strPATHNAME As String ' 読み込み時パス
Dim strFILENAME As String ' 読み込み時ファイルネーム
Dim objWBK As Workbook ' オブジェクト
Dim xlAPP As Application ' application
Set xlAPP = Application

Dim questions() As String ' ファイル作成時名前格納
Dim saveFolder As String ' 保存用フォルダ名格納
Dim answer() As String ' 回答格納
Dim i, j, k, l ' カウンター



' ----------------------------------
' 読み込みフォルダ、作成フォルダ指定
' ----------------------------------
MsgBox "回答済みアンケートファイル読み込み先を選択してください" & vbCrLf & "フォルダの階層は一つまでです。"
strPATHNAME = SelectFolder()
If strPATHNAME = "" Then Exit Sub ' 戻り値ないなら終了（キャンセルとか）

MsgBox "保存先を選択してください"
saveFolder = SelectFolder()
If saveFolder = "" Then Exit Sub ' キャンセルしたら終了


With xlAPP
      .ScreenUpdating = False             ' 画面描画停止
      .EnableEvents = False               ' イベント動作停止
      .EnableCancelKey = xlErrorHandler   ' Escキーでエラートラップする
      .Cursor = xlWait                    ' カーソルを砂時計にする
End With
On Error GoTo ErrorHandler
' ----------------------------------
' ここからファイルを読み込み
' ----------------------------------

strFILENAME = Dir(strPATHNAME & "\*.xls", vbNormal) ' xlsファイルがあるかどうか
If strFILENAME = "" Then ' なけりゃ終了
    MsgBox "このフォルダにはExcelワークブックは存在しません。"
    Exit Sub
End If

i = 0
Do While strFILENAME <> "" ' ファイルを順次処理
    '-----------------------------------------------------------------------
    '             ↓↓↓ 検索した１ファイル単位の処理 ↓↓↓
    ' ステータスバーに処理ファイル名を表示
    xlAPP.StatusBar = strFILENAME & " 処理中．．．．"
    
    ' ワークブックを開く(読み取り専用)
    Set objWBK = Workbooks.Open( _
        Filename:=strPATHNAME & "\" & strFILENAME, _
        UpdateLinks:=False, ReadOnly:=True)

    ' いいとこ取得する
    ReDim Preserve answer(QUES_NO, QUES_NO, 2)
    For j = 0 To QUES_NO
        For k = 0 To 1
            answer(i, j, k) = objWBK.Sheets(1).Cells(Range(READPOINT).Row + j, Range(READPOINT).Column + k).Value
        Next k
    Next j
    'MsgBox (objWBK.Sheets(1).Range("B1"))
    ' 開いたブックをClose
    objWBK.Close SaveChanges:=False
    '-----------------------------------------------------------------------
    ' 次のファイル名を参照
    strFILENAME = Dir
    i = i + 1
Loop

' ----------------------------------
' ここからファイルを作成
' ----------------------------------

' 質問を取得
i = 0

Do While Cells(Range(STARTPOINT).Row + i, Range(STARTPOINT).Column).Value <> ""
    ReDim Preserve questions(i)
    questions(i) = Cells(Range(STARTPOINT).Row + i, Range(STARTPOINT).Column).Value
    i = i + 1
Loop

' ファイルを作成し集計結果書き込み保存
For i = 0 To UBound(questions)
    l = 0 ' カウント用
    Workbooks.Add ' 新規ワークブック作成
    With ActiveWorkbook.Sheets(1)
        .Columns(Range(STARTPOINT).Column).ColumnWidth = 120
        .Range(STARTPOINT).Interior.ColorIndex = 35
        .Range(STARTPOINT).Font.Bold = True
        .Range("A1").Value = "回答♪"
        .Range(STARTPOINT).Value = questions(i)
    End With

    For j = 0 To UBound(answer) - 1
        For k = 0 To UBound(answer, 2) - 1
            If answer(j, k, 0) = ActiveWorkbook.Sheets(1).Range(STARTPOINT).Value And answer(j, k, 1) <> "" Then
                ActiveWorkbook.Sheets(1).Cells(Range(STARTPOINT).Row + l + 1, Range(STARTPOINT).Column).Value = answer(j, k, 1) ' cellに書き込み
                l = l + 1
            End If
        Next k
    Next j
    With ActiveWorkbook.Sheets(1).Range(STARTPOINT & ":" & Cells(l + Range(STARTPOINT).Row, Range(STARTPOINT).Column).Address).Borders ' 罫線を引く
        .Color = vbBlack
        .LineStyle = xlContinuous
        .Weight = xlThin
        .Range(STARTPOINT & ":" & Cells(l + Range(STARTPOINT).Row, Range(STARTPOINT).Column).Address).Font.Size = 9 ' フォントサイズの設定
    End With
    ActiveWorkbook.SaveAs Filename:=saveFolder & "\" & questions(i) & "の回答結果.xls", FileFormat:=xlNormal ' ファイル名をつけ保存
    ActiveWorkbook.Close ' 閉じる
Next i

' ----------------------------------
' 終了時処理
' ----------------------------------
With xlAPP
    .StatusBar = False                  ' ステータスバーを復帰
    .EnableEvents = True                ' イベント動作再開
    .EnableCancelKey = xlInterrupt      ' Escキー動作を戻す
    .Cursor = xlDefault                 ' カーソルをデフォルトにする
    .ScreenUpdating = True              ' 画面描画再開
End With

    MsgBox "完了！"
Exit Sub


ErrorHandler: ' 何かエラーがおきたら
With xlAPP
    .StatusBar = False                  ' ステータスバーを復帰
    .EnableEvents = True                ' イベント動作再開
    .EnableCancelKey = xlInterrupt      ' Escキー動作を戻す
    .Cursor = xlDefault                 ' カーソルをデフォルトにする
    .ScreenUpdating = True              ' 画面描画再開
    MsgBox "エラー。" & Err.Description & vbCrLf & "だめそうだったら連絡してｗ"
End With

End Sub


' フォルダ選択用
Function SelectFolder()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            SelectFolder = .SelectedItems(1)
        End If
    End With
End Function

リファクタしてないしコード汚いけど、一度こっきりのマクロだから載せておわり！