'ワークシートにカレンダーを作成するマクロ

'セルを1つ選択してMyCalendarマクロを実行してください。

Option Explicit

Sub MyCalendar()
    Const myTitle = "カレンダーの作成"
    Dim i As Long, j As Long, k As Long
    Dim w As Double
    Dim address1 As String, address2 As String

    On Error GoTo err_1

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲を選択して実行してください。", _
            vbExclamation, myTitle
        Exit Sub
    End If

    ActiveCell.Resize(8, 7).Select
    If MsgBox("選択範囲にカレンダーを作成します。", _
        vbOKCancel Or vbExclamation, myTitle) <> vbOK Then Exit Sub
    Application.ScreenUpdating = False
    Selection.Clear
    With ActiveCell
        .Range("B1:E1").Value = Array(Year(Date), "年", Month(Date), "月")
        .Range("G1").FormulaR1C1 = _
            "=DATE(RC[-5],RC[-3],1)-WEEKDAY(DATE(RC[-5],RC[-3],1),1)"
        .Range("A2:G2").Value = Array("日", "月", "火", "水", "木", "金", "土")
        address1 = .Range("G1").Address(False, False)
        address2 = .Range("D1").Address(False, False)
        With .Range("A3")
            k = 1
            For i = 1 To 6
                For j = 1 To 7
                    .Cells(i, j).Formula = _
                        "=IF(MONTH(" & address1 & "+" & k & ")=" & _
                        address2 & ",DAY(" & address1 & "+" & k & "),"""")"
                    k = k + 1
                Next
            Next
        End With

        '書式設定
        With .Range("B1").EntireColumn
            .AutoFit
            .ColumnWidth = .ColumnWidth + 1
            w = .ColumnWidth
        End With
        .Range("A1:G1").ColumnWidth = w
        .Range("A2:G2").HorizontalAlignment = xlCenter
        .Range("G1").NumberFormat = """"";"""""
        .Range("A2:A8").Font.ColorIndex = 3
        .Range("G2:G8").Font.ColorIndex = 5
        With .Range("A1:G8")
            .Interior.ColorIndex = 2
            With .Borders(xlTop)
                .Weight = xlThin
                .ColorIndex = 15
            End With
            With .Borders(xlBottom)
                .Weight = xlThin
                .ColorIndex = 15
            End With
            .BorderAround LineStyle:=xlDouble, ColorIndex:=16
        End With
        With .Range("A2:G2")
            With .Borders(xlTop)
                .LineStyle = xlDouble
                .ColorIndex = 16
            End With
            With .Borders(xlBottom)
                .LineStyle = xlDouble
                .ColorIndex = 16
            End With
        End With
        i = Date - .Range("G1").Value - 1
        .Cells(3 + i \ 7, i Mod 7 + 1).Select
    End With
    Exit Sub
err_1:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, myTitle
End Sub