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さて、うまくいくといいが…。
コメント