VBAで集計元のファイル名を取得する

質問

フォルダの中に、あるアンケートに対する回答のエクセルファイルがあり(名前はバラバラ)、別の場所にその回答を一覧に並べるための"集計用ファイル"がります。このアンケートの回答ファイルは日々数が追加されて行くので、毎日"集計用ファイル"に回答を得た分を転記し日付の名前でもつけて保存して行きたいのです。エクセルマクロを使用して、回答ファイルの特定の部分に入力された内容を一人一列となるように"集計用ファイル"へ転記します。こちらで教えて頂いたりネットや本を見て下記までは理解しました。

■質問
各行の先頭に転記元のファイル名も記入するにはどの様な記述が必要かおしえてください。いろいろ試したのですが、力量不足でエラーもしくは全く反映されないものしか出来ませんでした。

よろしくお願い致します。

=============================================
Sub 転記2()

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("Sheet1").Rows("1:1").Copy _
ThisWorkbook.Sheets("Sheet1").Cells(MaxRow, 1)
MaxRow = MaxRow + 1

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

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

回答No.2

merlionXX · ベストアンサー

おはようございます。merlionXXです。
前回の続きのようですね。

Workbooks(Target).Sheets("Sheet1").Rows("1:1").Copyと、1行目全部をコピーしているのはデータの範囲（どの列までなのか）が一定ではないからなのでしょうか？
だったらこうしてみてください。入力のある最右列の列番号を取得しXとします。

Sub 転記2()

Dim WorkPath As String
Dim Target As String
Dim MaxRow As Long, x As Long

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

Do While Target <> ""
If Target <> ThisWorkbook.Name Then

Workbooks.Open WorkPath & "\" & Target

With Workbooks(Target)
With .Sheets("Sheet1")
x = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 1), .Cells(1, x)).Copy ThisWorkbook.Sheets("Sheet1").Cells(MaxRow, 2)
End With
ThisWorkbook.Sheets("Sheet1").Cells(MaxRow, 1).Value = Target
MaxRow = MaxRow + 1
.Close SaveChanges:=False
End With
End If
Target = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "転記が終了しました。"
End Sub

お礼

またまたありがとうございました。
イロイロな書き方がるんですね。
本当に勉強になります。

前回教えて頂いた内容もあわせ、ここ数日でぐっと理解が進みました。ありがとうございました。<(_ _)>

回答No.3

n-jun

＃１です。

回答ではないですが読み込みたいシートと範囲が決まっているのなら、

ブックを開かないで読む
http://officetanaka.net/excel/vba/tips/tips28.htm
も一読されておくと良いかもです。

回答No.1

n-jun

＞Workbooks(Target).Sheets("Sheet1").Rows("1:1").Copy
これが例えばＡ～Ｆ列なら
～.Range("A1:F1").Copy
として

＞ThisWorkbook.Sheets("Sheet1").Cells(MaxRow, 1)
ThisWorkbook.Sheets("Sheet1").Cells(MaxRow, 2)
⇒Ｂ列に貼付け

ThisWorkbook.Sheets("Sheet1").Cells(MaxRow, 1).Value = Target
を追加すればよいのでは？

お礼

無事に名前を取得できました。
ありがとうございます。

よりシンプルな書き方を教えて頂きどんどん理解が進んできました。もう一歩でブレイクスルーしそうな予感です。