エクセルに入力されたアンケートの回答をマクロで集計する。

質問

画像をアップしたので、こちらを見ていただくと分かりやすいと思いますが、同一フォルダの中に、あるアンケートに対する回答のエクセルファイル(全く同じ形式でだが、ブックの名前に規則性はない)があり、別の場所にその回答を一覧に並べるための"集計用ファイル"がります。このアンケートの回答ファイルは日々数が追加されて行くので、毎日"集計用ファイル"に回答を得た分を転記し日付の名前でもつけて保存して行きたいのです。エクセルマクロを使用して、この"Book1"～"BookXXX"の特定の部分に入力された内容を一人一列となるように"集計用ファイル"のB列から右へ右へと転記したいと考えています。

下記、内容を簡単にしたサンプルを作り、VBAを書いてはみたものの、やはり動きませんでした。(セルは例として３つのみ転記しようとしています)

関連する質問もこちらにさせて頂いたのですが、まだ独力で解決できず再度投稿させて頂きました。よろしくお願いいたします。

Sub 転記()

Dim WorkPath As String
Dim Target As String
Dim MaxRow As Long

Application.ScreenUpdating = False

WorkPath = "C:\Documents and Settings\Zawa\デスクトップ\Test"
Target = Dir(WorkPath & "\*.xls", vbNormal)
MaxRow = 1

Do While Target <> ""
Workbooks.Open WorkPath & "\" & Target

Workbooks(Target).Sheets("Sum").Select
Range("C7").Select
Selection.Copy
ThisWorkbook.Sheets("Sheet1").Select
Range("B3").Select
ActiveSheet.Paste

Workbooks(Target).Sheets("Sum").Select
Range("C10").Select
Application.CutCopyMode = False
Selection.Copy
ThisWorkbook.Sheets("Sheet1").Select
Range("B4").Select
ActiveSheet.Paste

Workbooks(Target).Sheets("Sum").Select
Range("D10").Select
Application.CutCopyMode = False
Selection.Copy
ThisWorkbook.Sheets("Sheet1").Select
Range("B5").Select
ActiveSheet.Paste

Workbooks(Target).Close SaveChanges:=False
Target = Dir()
Loop

MsgBox "転記が終了しました。"
End Sub

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.1

merlionXX · ベストアンサー

集計用BOOKが同じフォルダーにおいてもいいように書いてみました。

Dim WorkPath As String
Dim Target As String
Dim i As Long

Application.ScreenUpdating = False
WorkPath = "C:\Documents and Settings\Zawa\デスクトップ\Test"

Target = Dir(WorkPath & "\*.xls", vbNormal)

i = 1
Do While Target <> ""
If Target <> ThisWorkbook.Name Then
Workbooks.Open WorkPath & "\" & Target
i = i + 1 '列番号右にを増やす
With Workbooks(Target)
.Sheets("Sum").Range("C7").Copy ThisWorkbook.Sheets("Sheet1").Cells(3, i)
.Sheets("Sum").Range("C10").Copy ThisWorkbook.Sheets("Sheet1").Cells(4, i)
.Sheets("Sum").Range("D10").Copy ThisWorkbook.Sheets("Sheet1").Cells(5, i)
.Close SaveChanges:=False
End With
End If
Target = Dir()
Loop

MsgBox i - 1 & "件のBOOKの転記が終了しました。"
End Sub

お礼

ありがとうございます！

特に
With Workbooks(Target)
.Sheets
.Sheets
.Sheets

と書ける事は始めて知りました。
非常に勉強になりました。

回答No.2

merlionXX

No1 merlionXXです。

Application.ScreenUpdating = True　　を
MsgBox i - 1 & "件のBOOKの転記が終了しました。"　の前に一行入れてください。