Excelの一括印刷で通し番号をつけるVBAマクロ

Excelファイルの一括印刷をしたときに、ヘッダーもしくはフッターに通し番号（連番）を入れるマクロが出来ないかと思い、試行錯誤しているのですが、行き詰っています。

考えたフローは以下の通りです。

1.（ダイアログボックスなどを用いて）対象フォルダを選択する
2.対象フォルダに入っているExcelファイルを1つ開き、
それぞれのシートのヘッダー（フッター）に通し番号を入れ、プリンタに情報を送り、ファイルを閉じる。
3.次のファイルを開き、それぞれのシートに2.でふった番号の次の番号から通し番号を入れ、
プリンタに情報を送り、ファイルを閉じる。
4.3.を繰り返し、ファイルが無くなったら終了。


まずはこのフローでマクロが作れるか、
もし作れるのであれば、お手数ですがコードも教えて頂けると非常に助かります。

No.1 回答者： keithin 回答日時： 2012/08/13 23:50

フォルダを指定するのはメンドクサイので、後で実装してください。

sub macro1()
　dim myPath as string
　dim myFile as string
　dim n as long
　dim s as worksheet
　mypath = "c:\test\"　　’後述参考ＵＲＬ参照
　myfile = dir(mypath & "*.xls*")

　do until myfile = ""
　　workbooks.open mypath & myfile
　　for each s in workbooks(myfile).worksheets
　　　n = n + 1
　　　s.pagesetup.rightheader=n
　　　s.printout
　　next
　　activeworkbook.close false
　　myfile = dir()
　loop
end sub


＃参考
http://officetanaka.net/excel/vba/tips/tips39.htm

この回答へのお礼

ありがとうございます。
こちらで組んでみますと、同じシートは同じ番号が付いて出てきてしまいました。
シートは同じでも出力ページ毎に番号を付けたいのですが、可能でしょうか？

お礼日時：2012/08/15 22:03

No.2 回答者： bin-chan 回答日時： 2012/08/13 23:55

「連番」とは「ページ番号にゲタをはかせる」で良いですか？

印刷ページ数は、以下のコマンドで拾えます。
Application.ExecuteExcel4Macro("get.document(50)")

1.（ダイアログボックスなどを用いて）対象フォルダを選択する
2．対象フォルダ内のxlsファイル一覧を取得し、シート上にブックとそれぞれのシート名一覧表を作成する。
3.ここでいったん止めて取得した一覧を、手動でメンテナンスしてください。
　さもないと、順序指定ができない・不要なシートにも付与しちゃう等、不都合満載。

以下、３．のすべての行について4.～6.をループ
4.メンテナンスした3.に基づいて、ブックとそれぞれのシートの印刷ページ数を拾う。
　　（ExecuteExcel4Macro）
5.各ブック・シートのヘッダーあるいはフッターへのページ番号出力を設定する。
6.4.の累計に基づいて初期ページ値を設定する。

※同様にして、印刷もVBA化すると便利。


同じものを実務で作りましたが、手元にないのでコードはご容赦ください。

この回答へのお礼

ありがとうございます。
一覧にしたところからどうコードを組めば良いのか分かりません。
ですが今後の参考にさせて頂きます。

お礼日時：2012/08/15 22:01

No.3 回答者： keithin 回答日時： 2012/08/16 00:45

あなたのヤリタカッタ事：

＞それぞれのシートのヘッダー（フッター）に通し番号を入れ

実はこれが嘘で、なんて事は無い単に連番のページ番号を振りたかっただけということですね。



sub macro2()
　dim myPath as string
　dim myFile as string
　dim w as workbook
　dim i as long

　application.screenupdating = false
　activesheet.copy
　set w = activeworkbook
　mypath = "c:\test\"　　’参考ＵＲＬ参照
　myfile = dir(mypath & "*.xls*")

　do until myfile = ""
　　workbooks.open mypath & myfile
　　workbooks(myfile).worksheets.move after:=w.worksheets(w.worksheets.count)
　　myfile = dir()
　loop

　application.displayalerts = false
　w.worksheets(1).delete
　application.displayalerts = true
　for i= 1 to w.worksheets.count
　　with w.worksheets(i).pagesetup
　　.rightheader ="&p"
　　.firstpagenumber = xlautomatic
　　end with
　next i

　w.worksheets.select
　w.printout
　w.close false
　application.screenupdating = true
end sub

この回答へのお礼

質問が分かりづらくて申し訳ございませんでした。
書いてくださったコードで、私のやりたいことは出来るはずなのですが、
（1つのブックにまとめて、何もデータのないシートを削除して印刷するということですよね？）
シートは全て削除または非表示に出来ませんというようなエラーが出てしまいます…

お礼日時：2012/08/16 22:11

No.4 回答者： keithin 回答日時： 2012/08/20 14:13

注意してたつもりでしたが見落としてたみたいですね。

失礼しました。

sub macro2r1()
　dim myPath as string
　dim myFile as string
　dim w as workbook
　dim i as long

　application.displayalerts = false
　application.screenupdating = false
　activesheet.copy
　set w = activeworkbook
　mypath = "c:\test\"　　’参考ＵＲＬ参照
　myfile = dir(mypath & "*.xls*")

　do until myfile = ""
　　workbooks.open mypath & myfile
　　workbooks(myfile).worksheets.move after:=w.worksheets(w.worksheets.count)
　　myfile = dir()
　loop

　w.worksheets(1).delete
　for i= 1 to w.worksheets.count
　　with w.worksheets(i).pagesetup
　　.rightheader ="&p"
　　.firstpagenumber = xlautomatic
　　end with
　next i

　w.worksheets.select
　w.printout
　w.close false
　application.screenupdating = true
　application.displayalerts = true
end sub