Excel VBA 一年間のカレンダーを作成する

はじめに

一年間の日ごとのカレンダーを一発作成したくコードを検討

エクセルマクロのイメージ

パラメータシートを準備し、西暦、スタート行と列、罫線の範囲を予め設定。

• パラメータのイメージ
  

• プロシジャーの説明
  ①calendasakusei
  メインプロシジャー

• 作成したエクセルマクロ

Option Explicit

'変数宣言
    Dim P1se As Long
    Dim P2ur As Long
    Dim P3gy As Byte
    Dim P4re As Byte
    Dim P5ke As Long
    Dim i As Long
    Dim youbi As Date
    Dim iro As Long
    Dim gyou As Long
    Dim retu As Long
    
'メインルーチン
Sub calendasakusei()
    Call Fnc_clea          'シート内の情報クリア
    Call Fnc_font          'シート内のフォント設定
    Call Fnc_Parayomiomi   'パラメータ読込
    Call Fnc_hinitiire     'カレンダー作成。この中で曜日判定+色塗り実施
    Call Fnc_syosikisettei '日付の書式設定
    Call Fnc_autofit       '列のオートフィット
    Call Fnc_senter        '文字センター設定
    Call Fnc_keisen        '罫線設定
End Sub
    

Function Fnc_Parayomiomi()
    Sheets("カレンダパラメータ").Select
    P1se = Cells(3, 3)
    P2ur = Cells(4, 3)
    P3gy = Cells(5, 3)
    P4re = Cells(6, 3)
    P5ke = Cells(7, 3)
End Function

Function Fnc_hinitiire()
    Sheets("カレンダ").Select
    Cells(P3gy, P4re).Value = "1/1/" & P1se      'ｽﾀｰﾄ位置へ2025/1/1を設定
    Cells(P3gy + 1, P4re).Value = "1/1/" & P1se  'ｽﾀｰﾄ位置の１つ下へ2025/1/1を設定
    youbi = Cells(P3gy + 1, P4re).Value          '曜日判定用でyoubiへ代入
    gyou = P3gy + 1                              '色塗用でgyouへ代入
    retu = P4re                                  '色塗用でretuへ代入
    
    Call Fnc_youbihantei                         '曜日判定用を実施。中で色塗りを実施。
    
    For i = 1 To P2ur
        Cells(P3gy, P4re + i).Value = Cells(P3gy, P4re + i - 1).Value + 1   'P3gyはｽﾀｰﾄ行､P4reはｽﾀｰﾄ列
        Cells(P3gy + 1, P4re + i).Value = Cells(P3gy, P4re + i).Value
        youbi = Cells(P3gy + 1, P4re + i).Value
        gyou = P3gy + 1
        retu = P4re + i
        
        Call Fnc_youbihantei
        
    Next i
End Function


Function Fnc_syosikisettei()
    Sheets("カレンダ").Select
    Range(Cells(P3gy, P4re), Cells(P3gy + 1, P4re + P2ur)).Select
    Selection.NumberFormatLocal = "m/d;@"
    Range(Cells(P3gy + 1, P4re), Cells(P3gy + 1, P4re + P2ur)).Select
    Selection.NumberFormatLocal = "aaa"

End Function

Function Fnc_youbihantei()
    Sheets("カレンダ").Select
    If (Weekday(youbi) = 1) Then  '日曜日
        iro = -16776961
        Call Fnc_ironuri
    ElseIf Weekday(youbi) = 7 Then '土曜日
        iro = -4165632
        Call Fnc_ironuri
    End If

End Function

Function Fnc_ironuri()
    Sheets("カレンダ").Select
    Range(Cells(gyou - 1, retu), Cells(gyou, retu)).Select
    With Selection.Font
        .Color = iro
        .TintAndShade = 0
    End With
End Function

Function Fnc_autofit()
    Sheets("カレンダ").Select
    Range(Cells(1, P4re), Cells(1, P2ur + P4re)).EntireColumn.AutoFit
End Function

Function Fnc_senter()
    Sheets("カレンダ").Select
    Range(Cells(1, P4re), Cells(1, P2ur + P4re)).EntireColumn.Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Function

Function Fnc_keisen()
    Dim BorderTypes As Variant
    Dim i As Integer

    Sheets("カレンダ").Select
    ActiveSheet.Cells(1, 1).Select
    Range(Cells(P3gy, P4re), Cells(P3gy + P5ke, P2ur + P4re)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    
    BorderTypes = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
    For i = LBound(BorderTypes) To UBound(BorderTypes)
        With Selection.Borders(BorderTypes(i))
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThin
        End With
    Next i
End Function

Function Fnc_font()
    Sheets("カレンダ").Select
    Cells.Select
    With Selection.Font
        .Name = "Meiryo UI"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
End Function

Function Fnc_clea()
    Dim BorderTypes As Variant
    Dim i As Integer

    Sheets("カレンダ").Select
    Cells.Select
    Selection.ClearContents

    BorderTypes = Array(xlDiagonalDown, xlDiagonalUp, xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)

    For i = LBound(BorderTypes) To UBound(BorderTypes)
        With Selection.Borders(BorderTypes(i))
            .LineStyle = xlNone
        End With
    Next i
    
    Selection.Interior.ColorIndex = xlNone
    Selection.Font.Color = RGB(0, 0, 0)
    Range("A2").Select

End Function