エクセルVBAでつくる物品購入稟議書テンプレート

Option Explicit
Sub 物品購入稟議Temp()
    Dim s As Long
    Dim MbBn As Long
        For s = 1 To Worksheets.Count
            If Worksheets(s).Name = "物品購入稟議書" Then
                MbBn = MsgBox("テンプレートシートは存在します。" & vbCrLf & _
                "今あるテンプレートシートをリネームしてください。" & vbCrLf & _
                "リネームするなら「YES」、上書きするなら「NO」を選択してください。" _
                , vbYesNo + vbExclamation, "入力問合せ")
                Exit For
            End If
        Next s
        If MbBn = vbYes Then
            Exit Sub
        ElseIf MbBn = vbNo Then
            Call シートクリア
        Else
            Call テンプレシート挿入
        End If
        Call ページ設定
        Call セルサイズ
        Call セルの書式設定
        Call セル入力項目
        Call 罫線A
        Range("A1").Select
        MsgBox "テンプレートを作成しました。"
End Sub

Sub シートクリア()
        With Worksheets("物品購入稟議書").Cells
            .Clear
            .UseStandardHeight = True
            .UseStandardWidth = True
        '    .DrawingObjects.Delete  'データ印等をクリアするときに
        End With
End Sub

Sub テンプレシート挿入()
        ThisWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = "物品購入稟議書"
End Sub

Sub ページ設定()
'余白
        With ActiveSheet.PageSetup
            .PaperSize = xlPaperA4
            .Orientation = xlPortrait
            .LeftMargin = Application.CentimetersToPoints(2)
            .RightMargin = Application.CentimetersToPoints(1.5)
            .TopMargin = Application.CentimetersToPoints(2)
            .BottomMargin = Application.CentimetersToPoints(1.5)
        End With
'フォント
        With Cells.Font
                .Name = "メイリオ"
                .Size = 12
        End With
End Sub


Sub セルサイズ()
    Dim i As Integer
        With Cells
            .RowHeight = 18.75
            .Columns(1).ColumnWidth = 12.5
            .Columns(9).ColumnWidth = 12.75
        End With
        
        With Range("A1:I43")
            Union(.Rows(8), .Rows("11:13"), .Rows(15)).Merge
        End With
        
        For i = 1 To 42
            If i = 1 Then
                Range(Cells(i, 8), Cells(i, 9)).Merge
            ElseIf i > 17 And i < 30 Then
                Range(Cells(i, 2), Cells(i, 4)).Merge
                Range(Cells(i, 6), Cells(i, 7)).Merge
                Range(Cells(i, 8), Cells(i, 9)).Merge
                If i = 18 Then Range("B18:H18").Interior.ColorIndex = 15
            ElseIf i = 31 Then
                Range(Cells(i, 2), Cells(i + 1, 9)).Merge
            ElseIf i = 34 Then
                Range(Cells(i, 2), Cells(i + 3, 9)).Merge
            ElseIf i > 38 Then
                Range(Cells(i, 2), Cells(i, 9)).Merge
            End If
        Next i
End Sub


Sub セルの書式設定()
        Range("H1").NumberFormatLocal = "ggge年mm月dd日"
        With Range("A8")
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
            .Font.Size = 15
        End With
        Union(Range("A15"), Range("B18"), Range("E18"), Range("F18"), _
        Range("H18"), Range("B29")).Select
        With Selection
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
        End With
End Sub

Sub セル入力項目()
        Range("H1") = Date
        Range("A4") = "■■部長　○○　○○　様"
        Range("G5") = "外商部販売2課　　○○　○○"
        Range("A8") = "×××            取り替え購入について"
        Range("A11") = "受注業務の効率改善を図るためにも下記事項のご検討をよろしくお願いいたします。"
        Range("A15") = "記"
        Range("A17") = "購入希望物品"
        Range("B18") = "品番・品名"
        Range("E18") = "数量"
        Range("F18") = "単価"
        Range("H18") = "予定金額"
        Range("B29") = "合計"
        Range("H29") = "=Sum(H19:H28)"
        Range("A31") = "予定購入先"
        Range("A34") = "申請理由と"
        Range("A35") = "予測効果"
        Range("A39") = "添付資料"
        Range("B39") = "申請理由を補強するデータ資料"
        Range("B40") = "購入見積書"
        Range("B41") = "商品カタログ"
        Range("I43") = "以上"
End Sub

Sub 罫線A()
        With Range("B18:I29")
            .Borders.LineStyle = xlContinuous
            .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
        End With
        With Range("E29")
            .Borders(xlEdgeLeft).LineStyle = False
            .Borders(xlEdgeRight).LineStyle = False
        End With
End Sub