VBA amacoda

アクティブシートと同じページ設定・シート書式・セル書式のシートを挿入するマクロ

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」キーで値・数式を、［ジャンプ］->［セル選択］でコメントや、オブジェクト、データの入力規則などを削除すればよい」ので、興味のある方はチャレンジしてみてください。

コメントを残す

RECOMMENDこちらの記事も人気です。