Insert the same worksheet as the active worksheet page setup, sheet formatting and range formatting
はじめに
今回のマクロは手間をかけないためのマクロです。
タイトルどおり、あるシートと同じページ設定、シート書式、セル書式のシートを挿入します。
ふつうはシートをコピーして全セルを選択し、「DELETE」キーで値・数式を［ジャンプ］->［セル選択］でコメントや、オブジェクト、データの入力規則などを削除すればよいのですが、それが面倒な方向けのマクロです。
今回のマクロは標準モジュールに登録し、［Alt + F8］で実行することを念頭において開発しました。
これから説明しますが、ボタンに登録する意味がないマクロなので、そのような形になりました。
・動作は無保証です。
・動作確認は、Windows 10 + Excel 2016でおこなっています。
今回はファイルは作成しておりませんが、モジュールをエクスポートしたものでよろしければ、ここからダウンロードしてください。
セキュリティ上の理由からファイルの拡張子は「.txt」となっています。「.bas」に変更してお使いください。
アクティブシートと同じページ設定・シート書式・セル書式のシートを挿入するマクロのソースコード
Option Explicit
'モジュールレベル変数宣言
'***ページ
'***印刷の向き
Private myOrientation As Long
'***拡大縮小印刷
Private myZoom As Variant '拡大／縮小
Private myFitToPagesWide As Variant '横ページ数
Private myFitToPagesTall As Variant '縦ページ数
'***用紙サイズ
Private myPaperSize As Long
'***印刷品質
Private myPrintQuality As Variant
'***先頭ページ番号
Private myFirstPageNumber As Long
'***余白
'***上
Private myTopMargin As Double
'***下
Private myBottomMargin As Double
'***左
Private myLeftMargin As Double
'***右
Private myRightMargin As Double
'***ヘッダ
Private myHeaderMargin As Double
'***フッタ
Private myFooterMargin As Double
'***ページ中央
Private myCenterHorizontally As Boolean '水平
Private myCenterVertically As Boolean '垂直
'***ページ余白にあわせてヘッダ・フッタを配置
Private myAlignMarginsHeaderFooter As Boolean
'***ヘッダ／フッタ
'***ヘッダ
Private myLeftHeader As String '左側
Private myCenterHeader As String '中央部
Private myRightHeader As String '右側
'***フッタ
Private myLeftFooter As String '左側
Private myCenterFooter As String '中央部
Private myRightFooter As String '右側
'***先頭ページに別のヘッダーおよびフッターを設定
Private myDifferentFirstPageHeaderFooter As Boolean
'先頭ページ
Private myFirstPage As Variant
'***奇数ページと偶数ページに異なるヘッダーとフッター
Private myOddAndEvenPagesHeaderFooter
'偶数ページ
Private myEvenPage As Variant
'***ヘッダーとフッターのサイズが文書に合わせて変更されるかどうか
Private myScaleWithDocHeaderFooter As Boolean
'***シート
'***印刷範囲
Private myPrintArea As String
'***印刷タイトル
Private myPrintTitleRows As String '行のタイトル
Private myPrintTitleColumns As String '列のタイトル
'***印刷
Private myPrintGridlines As Boolean '枠線
Private myPrintHeadings As Boolean '行列番号
Private myBlackAndWhite As Boolean '白黒印刷
Private myPrintComments As Long 'コメント
Private myPrintNotes As Boolean 'コメント（セル内）
Private myDraft As Boolean '簡易印刷
'***ページの方向
Private myOrder As Long '(左から右・上から下)
Private Property Let Switch(ByVal Flag As Boolean)
With Application
.ScreenUpdating = Not Flag
.PrintCommunication = Not Flag
End With
End Property
Public Sub S_CloneWS()
Switch = True
On Error GoTo HandleError
Dim CopyWS As String: CopyWS = ActiveSheet.Name
Worksheets.Add.Move After:=Worksheets(CopyWS)
Dim PasteWS As String: PasteWS = CopyWS & "(0)"
ActiveSheet.Name = PasteWS
Call S_CopyPageSetup(CopyWS)
Call S_PastePageSetup(PasteWS)
Call S_CopyWSFormat(CopyWS, PasteWS)
Worksheets(PasteWS).Cells(1, 1).Select
On Error GoTo 0
Switch = False
Exit Sub
HandleError:
Dim myErr As String
myErr = "エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description
MsgBox myErr, vbExclamation, "エラー発生！"
End Sub
Private Sub S_CopyPageSetup(ByVal WS As String)
On Error Resume Next
With Worksheets(WS).PageSetup
myPrintTitleRows = .PrintTitleRows
myPrintTitleColumns = .PrintTitleColumns
myPrintArea = .PrintArea
myLeftHeader = .LeftHeader
myCenterHeader = .CenterHeader
myRightHeader = .RightHeader
myLeftFooter = .LeftFooter
myCenterFooter = .CenterFooter
myRightFooter = .RightFooter
myDifferentFirstPageHeaderFooter _
= .DifferentFirstPageHeaderFooter
myFirstPage = .FirstPage
myOddAndEvenPagesHeaderFooter _
= .OddAndEvenPagesHeaderFooter
myOddAndEvenPagesHeaderFooter = .OddAndEvenPagesHeaderFooter
myEvenPage = .EvenPage
myScaleWithDocHeaderFooter = .ScaleWithDocHeaderFooter
myLeftMargin = .LeftMargin
myRightMargin = .RightMargin
myTopMargin = .TopMargin
myBottomMargin = .BottomMargin
myHeaderMargin = .HeaderMargin
myFooterMargin = .FooterMargin
myAlignMarginsHeaderFooter = .AlignMarginsHeaderFooter
myPrintHeadings = .PrintHeadings
myPrintGridlines = .PrintGridlines
myPrintComments = .PrintComments
myPrintNotes = .PrintNotes
myPrintQuality = .PrintQuality
myCenterHorizontally = .CenterHorizontally
myCenterVertically = .CenterVertically
myOrientation = .Orientation
myDraft = .Draft
myPaperSize = .PaperSize
myFirstPageNumber = .FirstPageNumber
myOrder = .Order
myBlackAndWhite = .BlackAndWhite
myZoom = .Zoom
myFitToPagesWide = .FitToPagesWide
myFitToPagesTall = .FitToPagesTall
End With
On Error GoTo 0
End Sub
Private Sub S_PastePageSetup(ByVal WS As String)
On Error Resume Next
With Worksheets(WS).PageSetup
.PrintTitleRows = myPrintTitleRows
.PrintTitleColumns = myPrintTitleColumns
.PrintArea = myPrintArea
.LeftHeader = myLeftHeader
.CenterHeader = myCenterHeader
.RightHeader = myRightHeader
.LeftFooter = myLeftFooter
.CenterFooter = myCenterFooter
.RightFooter = myRightFooter
.DifferentFirstPageHeaderFooter _
= myDifferentFirstPageHeaderFooter
.FirstPage = myFirstPage
.OddAndEvenPagesHeaderFooter = myOddAndEvenPagesHeaderFooter
.EvenPage = myEvenPage
.ScaleWithDocHeaderFooter = myScaleWithDocHeaderFooter
.LeftMargin = myLeftMargin
.RightMargin = myRightMargin
.TopMargin = myTopMargin
.BottomMargin = myBottomMargin
.HeaderMargin = myHeaderMargin
.FooterMargin = myFooterMargin
.AlignMarginsHeaderFooter = myAlignMarginsHeaderFooter
.PrintHeadings = myPrintHeadings
.PrintGridlines = myPrintGridlines
.PrintComments = myPrintComments
.PrintNotes = myPrintNotes
.PrintQuality = myPrintQuality
.CenterHorizontally = myCenterHorizontally
.CenterVertically = myCenterVertically
.Orientation = myOrientation
.Draft = myDraft
.PaperSize = myPaperSize
.FirstPageNumber = myFirstPageNumber
.Order = myOrder
.BlackAndWhite = myBlackAndWhite
.Zoom = myZoom
.FitToPagesWide = myFitToPagesWide
.FitToPagesTall = myFitToPagesTall
End With
On Error GoTo 0
End Sub
Private Sub S_CopyWSFormat(ByVal OriginalWS As String, _
ByVal TargetWS As String)
On Error Resume Next
Worksheets(OriginalWS).Activate
Dim myZoom As Variant: myZoom = ActiveWindow.Zoom
Cells.Copy
Worksheets(TargetWS).Activate
Cells(1, 1).PasteSpecial Paste:=xlFormats
ActiveWindow.Zoom = myZoom
End Sub
アクティブシートと同じページ設定・シート書式・セル書式のシートを挿入するマクロの概説
モジュールレベル変数とPageSetupオブジェクトのプロパティ
Worksheet.PageSetupオブジェクトには、48のプロパティがあります。つまり、それだけの設定項目があるということです。
このうち、シートのクローン（コピー）を作るのに必要なプロパティは37個あります。それらは、数値を設定するものか、チェックを入れてオン・オフを表すものです。
使い方としては単純なものなので、次のページから該当のプロパティを調べればほとんどのことはわかります。
PageSetup オブジェクト (Excel)
カンタンな説明でよければ、本マクロ内のモジュールレベル変数のコメントを参照してください。
モジュールレベル変数はすべて「my」＋「プロパティ名」という変数名になっています。
「myPaperSize」が用紙サイズを表すとか、「myPrintQuality」が印刷品質を表すとか、そういうもののことです。
今回使用しなかったプロパティ
ヘッダ・フッタに画像を挿入するためのプロパティはわたしがそういうことをしないので、今回はマクロには使いませんでした。
しかし、会社の資料で必ず同じ画像をヘッダ・フッタに挿入するという方もいらっしゃると思います。その手間をマクロで自動化したいというニーズもあるかと思います。
そういうときは次のページが一番役に立つでしょう。
PageSetup.CenterFooterPicture プロパティ (Excel)
ここには次の例があげられています。
Sub InsertPicture()
With ActiveSheet.PageSetup.CentertFooterPicture
.FileName = "C:\Sample.jpg"
.Height = 275.25
.Width = 463.5
.Brightness = 0.36
.ColorType = msoPictureGrayscale
.Contrast = 0.39
.CropBottom = -14.4
.CropLeft = -28.8
.CropRight = -14.4
.CropTop = 21.6
End With
'Enable the image to show up in the center footer.
ActiveSheet.PageSetup.CenterFooter = "&G"
End Sub
ここにあげられているプロパティを参考にして改造すれば、うまく自動化できると思います。
ちなみに画像を挿入できる箇所は左・中・右のヘッダ・フッタの計6か所あり、プロパティも6個あります。その6個をあげておきます。
PageSetup.LeftHeaderPicture プロパティ (Excel)
PageSetup.CenterHeaderPicture プロパティ (Excel)
PageSetup.RightHeaderPicture プロパティ (Excel)
PageSetup.LeftFooterPicture プロパティ (Excel)
PageSetup.CenterFooterPicture プロパティ (Excel)
PageSetup.RightFooterPicture プロパティ (Excel)
このプロパティの記事も参考になると思います。
PictureFormat.ColorType プロパティ (Excel)
プロパティプロシージャ「Switch」の解説
以前にもプロパティプロシージャは使いましたが、今回はこのマクロを高速化するのに関係ありそうなものに絞ってプロパティを設定しています。
Private Property Let Switch(ByVal Flag As Boolean)
With Application
.ScreenUpdating = Not Flag
.PrintCommunication = Not Flag
End With
End Property
「ScreenUpdating」プロパティはマクロを書く方にはおなじみでしょうが、「PrintCommunication」プロパティはあまりなじみがないと思います。
しかし、「PrintCommunication」プロパティを「False」に設定すると、「PageSetup」プロパティを設定するコードの実行を高速化することができます。つまり、このマクロを高速化できる、ということです。
「S_CloneWS」プロシージャの解説
Public Sub S_CloneWS()
Switch = True
On Error GoTo HandleError
Dim CopyWS As String: CopyWS = ActiveSheet.Name
Worksheets.Add.Move After:=Worksheets(CopyWS)
Dim PasteWS As String: PasteWS = CopyWS & "(0)"
ActiveSheet.Name = PasteWS
Call S_CopyPageSetup(CopyWS)
Call S_PastePageSetup(PasteWS)
Call S_CopyWSFormat(CopyWS, PasteWS)
Worksheets(PasteWS).Cells(1, 1).Select
On Error GoTo 0
Switch = False
Exit Sub
HandleError:
Dim myErr As String
myErr = "エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description
MsgBox myErr, vbExclamation, "エラー発生！"
End Sub
このプロシージャがメインのプロシージャです。
Dim CopyWS As String: CopyWS = ActiveSheet.Name Worksheets.Add.Move After:=Worksheets(CopyWS) Dim PasteWS As String: PasteWS = CopyWS & "(0)" ActiveSheet.Name = PasteWS
「CopyWS」はコピー元（コピーしてくる）シート名を格納する変数名。「PasteWS」はコピー先（コピーしてやる）シート名を格納する変数名。
そして、実際にシート名を変数に格納しています。
コピー元シートの後ろ（右側）に新規シートを作成し、そのシート名を「コピー元シート名」＋「(0)」としています。
Call S_CopyPageSetup(CopyWS) Call S_PastePageSetup(PasteWS) Call S_CopyWSFormat(CopyWS, PasteWS)
「Call S_CopyPageSetup(CopyWS)」でコピー元のシートからページ設定関係のプロパティの設定値をコピーします。
「Call S_PastePageSetup(PasteWS)」でコピー先のシートに設定値をペーストします。
「Call S_CopyWSFormat(CopyWS, PasteWS)」で設定値のコピペではコピーできない「ActiveWindow」の設定をコピペします。
「S_CopyPageSetup」プロシージャの解説
Private Sub S_CopyPageSetup(ByVal WS As String) On Error Resume Next ～～～～～～～～ On Error GoTo 0 End Sub
各プロパティの設定値を変数に格納しています。この変数はモジュールレベル変数なので、他のプロシージャでこの変数に格納された設定値を使うことができます。
「S_PastePageSetup」プロシージャの解説
Private Sub S_PastePageSetup(ByVal WS As String) On Error Resume Next ～～～～～～～～ On Error GoTo 0 End Sub
「S_CopyPageSetup」でモジュールレベル変数に格納した設定値をすぐにこのプロシージャで各プロパティに設定しています。
みなさんもモジュールレベル変数を使うときは、いったん設定値を変数に格納したら、すぐに新たに格納されるべきプロパティに設定してください。いくら有効範囲がモジュールレベルだからといって、いつ設定値が消えて変数が初期化されるかわかりません。これはVBAの仕様です。Microsoftがこのことについて何も保証していません。いつ設定値が消えても文句は言えないということです。だから、すぐ使いましょう。
これについて詳しく知りたい方は次のページをお読みください。
Excel VBA を学ぶなら moug モーグ｜即効テクニック｜モジュールレベル変数の値が消えるとき
「S_CopyWSFormat」プロシージャの解説
Private Sub S_CopyWSFormat(ByVal OriginalWS As String, _
ByVal TargetWS As String)
On Error Resume Next
Worksheets(OriginalWS).Activate
Dim myZoom As Variant: myZoom = ActiveWindow.Zoom
Cells.Copy
Worksheets(TargetWS).Activate
Cells(1, 1).PasteSpecial Paste:=xlFormats
ActiveWindow.Zoom = myZoom
End Sub
このプロシージャでは、プロパティの設定値のコピペではコピーできない「ActiveWindow」関連の設定値をコピペしています。また、セルの書式もすべてコピペしています。
おわりに
今回は、「PageSetup」オブジェクトのプロパティを使って、シートのクローンを作りましたが、冒頭にも書いたように「シートをコピーして全セルを選択し、「DELETE」キーで値・数式を、［ジャンプ］->［セル選択］でコメントや、オブジェクト、データの入力規則などを削除すればよい」ので、興味のある方はチャレンジしてみてください。
コメントを残す