【Excel VBA】アンケートを集計するマクロ

Excel VBA

2020.03.01 2018.04.19

Yahoo!知恵袋をツラツラと見ていると、なんだかとっても困っていそうな人を見つけてしまった。

回答しようとしたけれど、なぜかYahooからサーバーのエラーが返ってきて回答できなかったのでこちらに掲載しておこうと思う。

元ネタはこちら。

なんでも300件ほどの相手先にアンケートのエクセルファイルを配布したのだけど、回答の集計シートを作るのを忘れて配布したとか。
おそらく本来ならそれぞれのブック内でそのブックの集計はされているので、データを全体の集計表にペーストすればおしまい、という話だったのだろう。

これは大変な困りごとである。助けなければ…。

以下のソースを新しいブックの標準モジュールに貼り付けて実行するといい。ただし質問の内容だけでは不明な点も多いので、こちらでいくつかの基本的な仕様は勝手に決めてある。違う条件で動作させるためにはさらに改良は必要だろう。

各アンケートのファイル形式は、コントロールを使用しているとのことなので「マクロ有効ブック」と仮定した。従って拡張子は「.xlsm」。
返却された回答ブックはひとつのフォルダにまとめて保存してあるものとした。
どんなアンケートかわからないので、こちらで以下のようなアンケートを勝手に作成した。シート上にアクティブx コントロールを配置してある。
集計するシートは3行目に集計の項目名が書いてあり、4行目からデータを落とし込んでいくものとした。
ファイルシステムオブジェクトを使っているので、「Microsoft Scripting Runtime」への参照設定をVBEでおこなう必要がある。

Option Explicit

Sub CollectAnswers()
' 初期設定
' 集計表の項目数と回答済みのファイルが保存されているフォルダのパス
    Const ITEMS_UBOUND As Integer = 8
    Dim ANK_PATH As String: ANK_PATH = ThisWorkbook.Path & "\" & "回答済み" & "\"
' 集計データを書き込むセル範囲の左上のセル位置（行と列）
    Const START_ROW As Integer = 4
    Const START_COLUMN As Integer = 1

' 回答済みのファイル数をカウント
' 集計表の行数になる
    Dim fso As New FileSystemObject
    Dim fol As Folder
    Set fol = fso.GetFolder(ANK_PATH)
    Dim fileCount As Integer
    fileCount = fol.Files.Count
    Set fol = Nothing
    Set fso = Nothing

    Application.ScreenUpdating = False

' 集計表のもとになる二次元配列
    Dim data
    ReDim data(fileCount - 1, ITEMS_UBOUND)

' ひとつずつファイルを開いて回答を収集
' 回答ファイル名の最後は ank.xlsm の文字が共通していると仮定
    Dim tmpBookName As String
    tmpBookName = Dir(ANK_PATH & "*ank.xlsm")
    Dim cnt As Integer
    Do While tmpBookName <> ""
        Workbooks.Open (ANK_PATH & tmpBookName)
        ' ブックを開いた時には回答シートがアクティブになっていると仮定
        With ActiveSheet
        ' テキストボックスはそのまま取り込む
            data(cnt, 0) = .TextBox1.Text
        ' はい／いいえのラジオボタンは１か０であらわす
            If .OptionButton1.Value Then
                data(cnt, 1) = 1
            ElseIf .OptionButton2.Value Then
                data(cnt, 1) = 0
            End If
        ' チェックボックスそれぞれを集計項目として１か０であらわす
            Dim i As Integer
            For i = 0 To 5
                data(cnt, i + 2) = CInt(.OLEObjects("CheckBox" & i + 1).Object.Value) ^ 2
            Next i
        ' テキストボックス
            data(cnt, 8) = .TextBox2.Text
        End With
        ActiveWorkbook.Close
        tmpBookName = Dir()
        cnt = cnt + 1
    Loop

' 二次元配列をセル範囲に落とす
    Range(Cells(START_ROW, START_COLUMN), Cells(START_ROW + fileCount - 1, START_COLUMN + ITEMS_UBOUND)) = data

    Application.ScreenUpdating = True
End Sub

さて、うまくいくといいが…。

コメント