Excel VBA 指定のフォルダ内の全ブックに対して順次コピペ 処理を行う方法

アンケートの集計を行っていますが、対象のファイルが多く、VBAを組もうとしていますが、初めての作業で、時間がなく、困っています。。。
以下、どのように組めば以下の作業ができるか、教えていただけますでしょうか。


Goal
・アンケート回答者２００人分の「PDFシート」とPDF出力元のExcelファイルの生成

作業の対象となるファイル
・回答済みファイル（.xlsl）、「Cファイル」とします。コピー元です。
　 -「Cファイル」は、フォルダZの中に200ファイル存在（①）

・マスタファイル（.xlsl）、ペースト先です。
　このファイルを下に回答者別にPDF、Excel出力を実施したいです

行いたい処理
・フォルダZにある回答済みファイルに全てに対し、以下の手順で処理を行いたい
　１．Cファイル内にある「Aシート」のデータを全てコピーし
　２．マスタファイル内の「貼り付け用」シートに張り付け
　３．マスタファイル内の「PDFシート」を、指定のフォルダXへPDF出力
　４．出力の際、PDFには、回答者名を含むファイル名をつける
　　　 -回答者名は、A4セルに入力されている
　５．PDFを出力したファイルは別途Excelファイルとしても、指定のフォルダYへ保存
　　　-ファイル名の条件は、上記PDFと同様
　６．ファイルは閉じて、次の回答者のCファイルに対して同じ処理を実施
　　　→これを２００ファイル分行ったら終了

以上です。

何卒、何卒よろしくお願いいたします・・・！！！！m(__)m

No.4 ベストアンサー 回答者： komugi3333 回答日時： 2019/04/17 21:12

あと、訂正と注意事項です。

Dim o_Wb01 As Workbook
Dim o_Wb02 As Workbook
Dim i As Integer

の3行を書く場所を間違えてしまいましたので、

Do While FileName <> "" ' ファイルがなくなるまで繰り返す

の上に移動させてください。

それから、プログラムを書きなおすときは、すべてのExcelファイルをいったん閉じてから、一番最初にプログラムをコピペしたファイルを再度ひらいて書き直して下さい。
このコードですと、書きだした別のExcelファイルのコードを書き直してしまうことになってしまいますので・・・。

いいかげんなサンプルを書いてしまい、本当に申し訳ございませんが、ステップ実行（F8キーを繰り返し押す実行方法）で、1行ずつ実行して動きをよく観察してください。

マスタファイルをコピーする部分は、普通に別名保存していますので、Excelのウィンドウも本来のマスタファイルの名前ではなく、別名保存したそのファイル名に変わってしまっているはずです。

そうなるのがまずかったら、マスタファイルを別名で保存するのはやめて、
・あらかじめ空のExcelファイルを作っておいて中身をコピペする方法、とか、
・マスタファイルを開きつつ、同じ内容のファイルを別のフォルダに複製する方法」
などを、他の方に別口で質問してみてください。

がんばってください。

この回答へのお礼

ありがとうございます。
いただいた内容を踏まえて、意図したマクロを組むことができました。

これで、ようやくまともに睡眠が取れそうです。。。。
貴重なお時間をいただき、回答をいただきありがとうございました。

お礼日時：2019/04/17 22:29

No.3 回答者： komugi3333 回答日時： 2019/04/17 20:53

サンプルプログラムはシート名やらなんやら「完全ではない」くて、「抜けてるところも多く・骨子のみ」なので、あくまでもヒントとしてお使いください。

ごめんなさいです。m( _ _ )m

早速ですが、

o_Wb02.Worksheets("sheet1").Range("A1:D4").Copy _
Destination:=o_Wb01.Worksheets("sheet2").Range("A1")

は

o_Wb02.Worksheets("Aシートの名前").Range("コピーしたいセル範囲").Copy _
Destination:=o_Wb01.Worksheets("マスタファイルの貼り付けたいシート名").Range("貼り付けの起点としたい左上のセルのアドレス")

に書き換えて実行してみてください。

「Aシートの名前」がまんまでそのまま「Aシート」という名前でしたら
o_Wb02.Worksheets("Aシート").Range・・・
というかたちになります。

あと、

'PDF出力用シートを選択
o_Wb01.Worksheets("sheet2").Activate

の部分も、

'PDF出力用シートを選択
o_Wb01.Worksheets("PDF出力したいシートの名前").Activate

に書き換えて実行してみてください。

それでもエラーになったり意図しない動きになってしまったら、大変申し訳ございませんが僕にはちょっとわかりませんので、別の質問を立てて聞くほうがよろしいかと思います。


ちなみにですが、「インデックスが有効範囲にありません」というエラーは、シートの名前（or インデックス番号）の指定やブックの名前（or インデックス番号）の指定が、「書き間違いや存在しないなどで」実際と違う場合によく出てきます。もしかしたらセルのアドレスの指定内容が書き間違っているときも出るかもしれません。

No.2 回答者： komugi3333 回答日時： 2019/04/17 18:09

何度もすみません。

実行すると、ファイルを選択するダイアログが出ますので、「D:\3」の中のどれかのxlsxを選んでOKしてください。そのあとは、「D:\3」の中のすべてのファイルが処理されます。

No.1 回答者： komugi3333 回答日時： 2019/04/17 18:07

完全じゃありませんけど、「D:\3」というフォルダにあるxlsxの内容を、読み出し元のファイルのSheet2貼り付けて、Sheet2を選んでから

「D:\3\PDF」フォルダへのPDF出力と
「D:\3\マスタ」フォルダへの「マスタファイルの別名書き出し」
をするサンプルです。

ぜんぜん完全じゃないので、ちゃんと作り変えてほしいのですが、何かの間違いが起こるといけませんので、テストは200個のファイルではやらないようにしてください。

「D:\3」というフォルダに適当にSheet1に値を書き込んだファイルを３つくらい作って（ファイル名はなんでもいいです）、テストしてみてください。


Option Explicit

Sub AllFilePdfMaterOutPut()

Dim FolderName As String '文字列を入れる変数として「FolderName」を使う
Dim index As Integer '数字を入れる変数として「index」を使う
Dim FileName As String '文字列を入れる変数として「FileName」を使う

FolderName = Application.GetOpenFilename 'ダイアログを用いて選択したファイルのパスをFolderNameとする①

If FolderName = "False" Then 'FolderNameが選択されていなければ作業を終了する
Exit Sub
End If

'今のフォルダ名には選択したファイル名含まれているので、ファイル名の部分を切り取る作業。
index = InStrRev(FolderName, "\") 'フォルダ名部分の文字数をカウントする
FolderName = Left(FolderName, index) ' カウントした文字数までの部分を切り取ってフォルダ名とする
FileName = Dir(FolderName & "*xls*") ' フォルダの中に含まれるファイルを取り出す

Application.DisplayAlerts = False

Do While FileName <> "" ' ファイルがなくなるまで繰り返す

Dim o_Wb01 As Workbook
Dim o_Wb02 As Workbook
Dim i As Integer

Set o_Wb01 = ActiveWorkbook
Set o_Wb02 = Workbooks.Open(FolderName & FileName) 'ファイルを開く


'Aシートに貼り付け
o_Wb02.Worksheets("sheet1").Range("A1:D4").Copy _
Destination:=o_Wb01.Worksheets("sheet2").Range("A1")
' Cells(1, 1) = 3 ' 変更を行う

'PDF出力用シートを選択
o_Wb01.Worksheets("sheet2").Activate

'D:\PDF というフォルダに、PDFを書き出し（ファイル名は応急処置でカウンタ変数で連番にした）
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="D:\3\PDF\Book" & i & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False

'D:\3\マスタ というフォルダに、マスタファイルを書き出し
'応急処置で、PDFと同じ名前。
'注意。ここで 200個のファイルのあるフォルダと同じフォルダに保存にしてしまうと、
'ここで別名保存したものも200個目以降の処理対象になってしまうので
'必ず別のフォルダを作っておいてそこを指定する。
o_Wb01.SaveAs FileName:="D:\3\マスタ\Book" & i & ".xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

' MsgBox "aaa"
Workbooks(Workbooks.Count).Save
Workbooks(Workbooks.Count).Close

FileName = Dir() '

i = i + 1
Loop

Application.DisplayAlerts = True

MsgBox "完了しました。"

End Sub

この回答へのお礼

丁寧なご回答ありがとうございます。

実行したところ、

'Aシートに貼り付け

の部分で、実行時エラー９（インデックスが有効範囲にありません。）　が出てきます。

この場合の原因は、お分かりになりますか？

お礼日時：2019/04/17 20:26