MW211 EXIT

devlog
ExcelVBA/シートをマクロ抜きで複写するクラス
2018年07月22日
┌──────────────────────────────────────┐
│Option Explicit                                                             │
│'***************************************************************************│
│'  クラス:シート複写                                                       │
│'***************************************************************************│
│Private m入力シート As Worksheet                                            │
│'===========================================================================│
│'  コンストラクタ                                                           │
│'===========================================================================│
│Private Sub Class_Initialize()                                              │
│    Set m入力シート = ThisWorkbook.Worksheets("入力")  ' 任意のシート名を   │
│End Sub                                                                     │
│'===========================================================================│
│'  デストラクタ                                                             │
│'===========================================================================│
│Private Sub Class_Terminate()                                               │
│End Sub                                                                     │
│'===========================================================================│
│'  実行                                                                     │
│'===========================================================================│
│Public Sub 実行(ByVal シート名 As String)                                   │
│    Dim シート As Worksheet                                                 │
│    Application.ScreenUpdating = False  ' 作業過程非表示                    │
│    ' シート追加                                                            │
│    For Each シート In Worksheets                                           │
│        If シート.Name = シート名 Then                                      │
│            MsgBox "同一シート名が既に存在します。", vbCritical, "処理中止" │
│            Exit Sub                                                        │
│        End If                                                              │
│    Next シート                                                             │
│    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = シート名     │
│    ' シート複写                                                            │
│    Call マクロ抜きシート複写(m入力シート, _                                │
│                              ThisWorkbook.Worksheets(シート名))            │
│    '                                                                       │
│    Application.GoTo m入力シート.Cells(1, 1)                                │
│    Application.ScreenUpdating = True   ' 作業過程非表示の解除              │
│End Sub                                                                     │
│'===========================================================================│
│'  マクロ抜きシート複写                                                     │
│'===========================================================================│
│Private Sub マクロ抜きシート複写(ByVal 入力シート As Worksheet, _           │
│                                 ByVal 出力シート As Worksheet)             │
│    Dim 表示倍率 As Long, 改頁 As Variant                                   │
│    ' コピー                                                                │
│    入力シート.Cells.Copy  ' コピー                                         │
│    With 出力シート.Cells(1, 1)                                             │
│        .PasteSpecial Paste:=xlValues   ' 値貼り付け                        │
│        .PasteSpecial Paste:=xlFormats  ' 書式貼り付け                      │
│        .Select                                                             │
│    End With                                                                │
│    ' 印刷設定の複写                                                        │
│    Call 印刷設定の複写(入力シート.PageSetup, _                             │
│                        出力シート.PageSetup)                               │
│    ' 改頁位置の複写                                                        │
│    For Each 改頁 In 入力シート.HPageBreaks                                 │
│        出力シート.HPageBreaks.Add 改頁.Location.Rows                       │
│    Next 改頁                                                               │
│    ' 表示倍率の複写                                                        │
│    入力シート.Select                                                       │
│    表示倍率 = ActiveWindow.Zoom                                            │
│    出力シート.Select                                                       │
│    ActiveWindow.Zoom = 表示倍率                                            │
│    ' クリップボードのクリア                                                │
│    Application.CutCopyMode = False                                         │
│    ' 上記のみではクリアできないものについては、                            │
│    ' 全セル選択から一セル選択に切り替える                                  │
│    ' →「図が大きすぎます。」エラー対策                                    │
│    入力シート.Cells(1, 1).Copy                                             │
│End Sub                                                                     │
│'===========================================================================│
│'  印刷設定の複写                                                           │
│'===========================================================================│
│Private Sub 印刷設定の複写(ByVal 入力 As Object, _                          │
│                           ByVal 出力 As Object)                            │
│    With 出力                                                               │
│        ' ヘッダ・フッタの複写                                              │
│        .LeftHeader = 入力.LeftHeader                                       │
│        .CenterHeader = 入力.CenterHeader                                   │
│        .RightHeader = 入力.RightHeader                                     │
│        .LeftFooter = 入力.LeftFooter                                       │
│        .CenterFooter = 入力.CenterFooter                                   │
│        .RightFooter = 入力.RightFooter                                     │
│        ' 印刷タイトルの複写                                                │
│        .PrintTitleRows = 入力.PrintTitleRows                               │
│        ' 印刷範囲の複写                                                    │
│        .PrintArea = 入力.PrintArea                                         │
│        .PaperSize = 入力.PaperSize                                         │
│        .Orientation = 入力.Orientation                                     │
│        .Zoom = 入力.Zoom                                                   │
│        .FitToPagesTall = 入力.FitToPagesTall                               │
│        .FitToPagesWide = 入力.FitToPagesWide                               │
│    End With                                                                │
│End Sub                                                                     │
│'***************************************************************************│
└──────────────────────────────────────┘
シートをマクロ抜きで複写するクラスを作ってみた。

以下のようにして使う。
┌──────────────────────────────────────┐
│Dim objシート複写 As New Classシート複写                                    │
│Call objシート複写.実行("出力")  ' 任意のシート名を指定                     │
└──────────────────────────────────────┘

ただ、印刷範囲あたりの処理はナイーヴ(Excelのバグ?)なので、
ボタン等があればおかしくなる可能性もあるので注意して使用のこと。
分類:ExcelVBA