おおぞらのとんび

はじめに
　Excelの印刷設定ですが、
　シートごとに設定する必要があり、
　シートを複数選択して一括での印刷設定ができません。
　（プリンタによっては可能な場合あるらしい。ドライバ依存？）
　各シートごとに印刷ダイアログを開いて、
　トレイや両面印刷、Nアップなどを設定しなければならないので大変面倒です。

　現在は下記の２通りしか方法がないようです。
　・プリンタの基本設定を変えてしまう。（印刷後に戻すこと）
　・PDFに変換してからPDFの印刷設定で変更する。

　ということでVBAで無理やりやってみました。
　印刷設定をしたシート１枚を「シートのコピー」をして、
　そこに印刷したいシートの「データ」と「ページ設定」をコピーしてます。



このプログラムについて
　『Excel2003』で動作確認しています。


まず初めにフォームの作成
　・新規でExcelを起動

　・上の図のようにフォームを作成手順は下
　１メニューの ツール > マクロ > Visual Basic Editor　でVisualBasic画面を起動
　２ VisualBasic画面の　メニューの 挿入 > ユーザーフォーム
　３フォームの中に「Label1」「ListBox1」「CommandButton1」「CommandButton2」「CommandButton3」を作成


続けてVBAでフォームを作成
　・フォームのコードへブログのコードをコピペ


最後に印刷設定シートの作成
　・どのシートでもいいのでシート名を「印刷設定」とする


操作方法
　１シート名「印刷設定」を開いてメニューの ファイル > 印刷 > プロパティーで印刷設定をする　
　２メニューの ツール > マクロ > Visual Basic Editor　でVisualBasic画面を起動
　３フォーム開いて実行する
　４「CommandButton1」クリックして印刷設定を変更したいシートがあるExcel選択
　５リストにシート名一覧が表示されるので除外したいシートを「CommandButton2」で削除
　６「CommandButton3」で実行すると（注意時間がかかります）
　　このExcelに印刷設定が変更されたシートが「シート名+印」で出力されます


あとがき
　コピー元のデータ保護のため読み取り専用で開いていますが、
　コピー元に印刷設定を変更したシートを出力したい場合は、
　コードの中のコメント部に従って操作してください。


--------------------------------------------------------------------
コードです。↓コピペしてください。


Private Sub CommandButton1_Click()
Dim objWkB As Workbook
Dim i As Integer

'変更ブック選択
Label1.Caption = Application.GetOpenFilename("EXCELファイル (*.xls),*.xls")

'変更ブックを開く(読み取り専用)
Set objWkB = Workbooks.Open(Filename:=Label1.Caption, UpdateLinks:=False, ReadOnly:=True)

'シート一覧取得
ListBox1.Clear
For i = 1 To objWkB.Worksheets.Count
ListBox1.AddItem (objWkB.Worksheets(i).Name)
Next

objWkB.Close SaveChanges:=False
End Sub

Private Sub CommandButton2_Click()
'リストから削除
ListBox1.RemoveItem (ListBox1.ListIndex)
End Sub

Private Sub CommandButton3_Click()
Dim objWkB As Workbook
Dim i As Integer
Dim strSheetNameC As String
Dim strSheetNameP As String

'変更ブックを開く(読み取り専用)
Set objWkB = Workbooks.Open(Filename:=Label1.Caption, UpdateLinks:=False, ReadOnly:=True)
'1 Set objWkB = Workbooks.Open(Filename:=Label1.Caption, UpdateLinks:=False, ReadOnly:=False)

'ListBox中の全シートについて繰り返す
For i = 0 To ListBox1.ListCount - 1
strSheetNameC = ListBox1.List(i)
strSheetNameP = ListBox1.List(i) + "印"

'印刷設定シートを複写
ThisWorkbook.Sheets("印刷設定").Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
'2 ThisWorkbook.Sheets("印刷設定").Copy After:=objWkB.Worksheets(objWkB.Worksheets.Count)
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = strSheetNameP
'3 objWkB.Worksheets(objWkB.Worksheets.Count).Name = strSheetNameP

'######################################################
'#コピー先を開いたブックと同じにしたい場合は
'# '1～'4のコメントを各行の上と入替えて
'#ここから下のThisWorkbookをobjWkBにすべて置き換えればいけるはず
'######################################################

'データコピー
objWkB.Activate
objWkB.Worksheets(strSheetNameC).Select
Cells.Select
Selection.Copy
'データ貼り付け
ThisWorkbook.Activate
ThisWorkbook.Worksheets(strSheetNameP).Select
Cells.Select
ActiveSheet.Paste

'*********************************************************
'*ページ設定コピー
'*ここの処理時間が長いので使用しないのをコメントに！
'*********************************************************
'タイトル
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PrintTitleRows = objWkB.Worksheets(strSheetNameC).PageSetup.PrintTitleRows
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PrintTitleColumns = objWkB.Worksheets(strSheetNameC).PageSetup.PrintTitleColumns
'印刷範囲
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PrintArea = objWkB.Worksheets(strSheetNameC).PageSetup.PrintArea
'ヘッダーフッター
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.LeftHeader = objWkB.Worksheets(strSheetNameC).PageSetup.LeftHeader
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.CenterHeader = objWkB.Worksheets(strSheetNameC).PageSetup.CenterHeader
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.RightHeader = objWkB.Worksheets(strSheetNameC).PageSetup.RightHeader
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.LeftFooter = objWkB.Worksheets(strSheetNameC).PageSetup.LeftFooter
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.CenterFooter = objWkB.Worksheets(strSheetNameC).PageSetup.CenterFooter
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.RightFooter = objWkB.Worksheets(strSheetNameC).PageSetup.RightFooter
'左余白（25.2mmに対する％）
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.LeftMargin = objWkB.Worksheets(strSheetNameC).PageSetup.LeftMargin
'右 〃
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.RightMargin = objWkB.Worksheets(strSheetNameC).PageSetup.RightMargin
'上 〃
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.TopMargin = objWkB.Worksheets(strSheetNameC).PageSetup.TopMargin
'下 〃
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.BottomMargin = objWkB.Worksheets(strSheetNameC).PageSetup.BottomMargin
'ヘッダー余白
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.HeaderMargin = objWkB.Worksheets(strSheetNameC).PageSetup.HeaderMargin
'フッター 〃
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.FooterMargin = objWkB.Worksheets(strSheetNameC).PageSetup.FooterMargin
'行列番号 True:印刷する False:しない
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PrintHeadings = objWkB.Worksheets(strSheetNameC).PageSetup.PrintHeadings
'セル枠線 True:印刷する False:しない
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PrintGridlines = objWkB.Worksheets(strSheetNameC).PageSetup.PrintGridlines
'セルメモ True:印刷する False:しない
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PrintNotes = objWkB.Worksheets(strSheetNameC).PageSetup.PrintNotes
'印刷品質（ドライバ制約に注意）
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PrintQuality = objWkB.Worksheets(strSheetNameC).PageSetup.PrintQuality
'水平中央寄せ True:する False:しない
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.CenterHorizontally = objWkB.Worksheets(strSheetNameC).PageSetup.CenterHorizontally
'垂直中央寄せ True:する False:しない
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.CenterVertically = objWkB.Worksheets(strSheetNameC).PageSetup.CenterVertically
'印刷の向き xlPortrait:縦 xlLandscape:横
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.Orientation = objWkB.Worksheets(strSheetNameC).PageSetup.Orientation
'簡易印刷 True:する False:しない
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.Draft = objWkB.Worksheets(strSheetNameC).PageSetup.Draft
'用紙サイズ xlPaperA4:A4
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PaperSize = objWkB.Worksheets(strSheetNameC).PageSetup.PaperSize
'先頭ページ番号
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.FirstPageNumber = objWkB.Worksheets(strSheetNameC).PageSetup.FirstPageNumber
'ページ付番順
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.Order = objWkB.Worksheets(strSheetNameC).PageSetup.Order
'白黒印刷 True:する False:しない
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.BlackAndWhite = objWkB.Worksheets(strSheetNameC).PageSetup.BlackAndWhite
'印刷倍率
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.Zoom = objWkB.Worksheets(strSheetNameC).PageSetup.Zoom
'横 1ページに印刷
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.FitToPagesWide = objWkB.Worksheets(strSheetNameC).PageSetup.FitToPagesWide
'縦 1　　　〃
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.FitToPagesTall = objWkB.Worksheets(strSheetNameC).PageSetup.FitToPagesTall
'セルのエラー
ThisWorkbook.Worksheets(strSheetNameP).PageSetup.PrintErrors = objWkB.Worksheets(strSheetNameC).PageSetup.PrintErrors

Next

objWkB.Close SaveChanges:=False
'4 objWkB.Close SaveChanges:=True
End Sub