【Excel VBA】 多くのファイルからのコピー貼り付け連続処理

質問

【やりたいこと】
アンケートを取った500個のxlsファイル（ファイル名は"001.xls"～"500.xls"まで、単純に規則的に数字が増えていく）があります。500個のファイルの中身（アンケートのフォーマット）は全て同じで、回答者の「答え」は"アンケート"というシートの"P6:S6"と"A70:AX70"という範囲に数列になって入っています。
この500個のファイルに対して、

（１）シートにはPassword付きの保護がかけてあるので、アンケート回答ファイルを開いたら保護を解除する
（２）"アンケート"というシートの、ある範囲（回答部分の"P6:S6"と"A70:AX70"）をコピーし、集計用の別ファイルへ貼り付けていく（×500人分）
（３）集計用の別ファイルに貼り付けるときは、1人目の"P6:S6"範囲の貼り付け先は"D4"、"A70:AX70"の範囲の貼り付け先は"I4"で、2人目はそれぞれ"D5"と"I5"、3人目は"D6"と"I6"、・・・とずらしていきます。（コピー元のセルは同じで、コピー先のセルがずれていきます）
（４）コピー貼り付けが終わったアンケート回答は、上書き保存をせずに終了する（再び保護がかかった状態に戻して終了する）

という操作を行うマクロを組みたいのです。

【つまづいている現状・・・】
とりあえず1人目の分だけ記録したマクロは以下の通りです。力技でやろうとすれば、"001.xls"を001～500まで、"D4"と"I4"を4～503まで、ずっと書き変えていけばいいんだと思いますが・・・。500人分を簡単にスッキリとまとめることはできませんでしょうか？
何卒よろしくお願い致します。

--------------------------------------------------------------
Workbooks.Open Filename:="D:\AAA\001.xls"
Sheets("アンケート").Select
ActiveSheet.Unprotect Password:="1234"
Range("P6:S6").Select
Selection.Copy
Windows("集計用ファイル.xls").Activate
Range("D4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("001.xls").Activate
ActiveWindow.SmallScroll Down:=8
Range("A70:AX70").Select
Application.CutCopyMode = False
Selection.Copy
Windows("集計用ファイル.xls").Activate
Range("I4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("001.xls").Activate
Application.DisplayAlerts = False
ActiveWindow.Close
--------------------------------------------------------------

回答No.2

end-u · ベストアンサー

セオリーとしては
Dim i　As Long
For i = 1 To 500
　　With Workbooks.Open("D:\AAA\" & Format$(i, "000") & ".xls", UpdateLinks:=0, ReadOnly:=True)
　　　　'コピー処理
　　　　.Close savechanges:=False
　　End With
Next
こんな感じでFor...Nextステートメントで1Bookずつ開いてコピー...のLoop処理にすればスッキリまとめる事ができます。

ですが今回のようにBook名、シート名、セルアドレスなどが、固定＆規則性がある変動値の場合は
ダイレクトに参照数式をセットする事もできます。こっちが速いです。

Sub test2()
　　Const f1 = "='D:\AAA\["
　　Const f2 = ".xls]アンケート'!"
　　Dim f As String
　　Dim i As Long

　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With
　　With ActiveSheet
　　　　For i = 1 To 500
　　　　　　f = f1 & Format$(i, "000") & f2
　　　　　　.Cells(i + 3, 4).Resize(, 4).Formula = f & "P6"
　　　　　　.Cells(i + 3, 9).Resize(, 50).Formula = f & "A70"
　　　　Next
　　　　With .Range("D4:G503")
　　　　　　.Copy
　　　　　　.PasteSpecial xlPasteValues
　　　　End With
　　　　With .Range("I4:BF503")
　　　　　　.Copy
　　　　　　.PasteSpecial xlPasteValues
　　　　End With
　　End With
　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
End Sub

※存在しないBookがあったり、フォルダ名を間違ったりすると[値の更新]ウィンドウが表示されます。
変更が必要な式の数量分繰り返されますので、設定には気をつけてください。
もしそうなった場合、[Ctrl]キーと[Break]キーを同時押しした後に[Esc]キー。...でデバッグできます。

お礼

教えていただいた２つ目のマクロでバッチリでした！！

大変助かりました。そしてとても勉強になりました。

ありがとうございました！！！

回答No.1

tarinko_06

ファイル名を変数にしてforで回すとか
フォルダの中に入れてぐるぐる回すとかって事？

お礼

おそらくご想像いただいてる内容かと推察しますが、
申し訳ありません、私の説明がよくなかったようで
伝わらなかったみたいです。。。

いずれにせよ、ありがとうございました。