Sibainu Relax Room

柴犬と過ごす

Excel シートにShapeカレンダーまとめ

少々の設定とコードのコピペで動作するようにまとめました。

「Excel シートにShapeカレンダー 1 」から「 ４ 」までのコードを２つのブロックにしました。
これに休日クラスを加えます。

シートのモジュール

copy

Option Explicit
'---------------------------------------
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim DateFormats             As Variant
Dim DateFormat              As Variant

    DateFormats = Array("yyyy/mm/dd", "yy/m/d", "yy/mm/dd", _
                        "d""日""", "dd""日""", "d/m/yyyy", _
                        "dd/mm/yyyy", "ggge", "ge")

    Call DeleteCal

    For Each DateFormat In DateFormats
        If InStr(Target.NumberFormatLocal, DateFormat) > 0 Then
            Call DispCalendarIcon
            Exit For
        End If
    Next
    
End Sub
'---------------------------------------
'
Private Sub DispCalendarIcon()
    Dim SHP                 As Object

    Set SHP = ActiveSheet.Pictures. _
            Insert(Application.Path & "\FORMS\1041\APPTS.ICO")

    With SHP
        '--------アクティブセルの1つ右のセル
        .Left = ActiveCell.Offset(0, 1).Left + 5
        .Top = ActiveCell.Offset(0, 1).Top + 2
        '--------名前
        .Name = "SHPIcon"
        '--------クリックしたときの動作
        .OnAction = "ShapeCalendar.OpenCalendar"
        .PrintObject = msoFalse
        .Placement = xlMove
        .Locked = msoTrue
    End With

End Sub

標準モジュール ShapeCalendar

セル横のアイコンの「 OnAction 」を「 ShapeCalendar.OpenCalendar 」としているため、標準モジュールのモジュール名を「 ShapeCalendar 」とします。

copy

Option Explicit

Private Enum YobiType
    Shuku = 10
    Kokumin = 11
    Hurikae = 12
    Kanrei = 13
End Enum

Private Enum IncFlg
    IncForward = 0
    IncBackward = -1
End Enum

Private shpHeight           As Long
Private shpWidth            As Long
Private TBT                 As Long
Private YBT                 As Long
Private DBT(1 To 6)         As Long
Private BL(1 To 7)          As Long

Private Const ColorSunday   As Long = vbRed
Private Const ColorSaturday As Long = vbBlue
Private Const ColorWeekday  As Long = vbBlack
Private Const ColorPreHome  As Long = 5288016

Private Const IntvDay       As String = "d"
Private Const IntvMonth     As String = "m"
Private Const IntvYear      As String = "yyyy"
Private Const IntvWeek      As String = "ww"

Private HoldDate            As Date
Private HoldYear            As Long
Private HoldMonth           As Long
Private HoldDay             As Long

Private CurDate             As Date
Private CurYear             As Long
Private CurMonth            As Long
Private CurDay              As Long

Private GetYobi             As C_Kyuzitu
Private Const FirstYobi     As Long = vbSunday
Private Yobi                As Variant
Private StartPosi           As Long
Private DaysAndWeeks()      As Long

Private SelectShape         As String
'---------------------------------------
'
Public Sub OpenCalendar()
    Dim I                   As Long
    Dim J                   As Long

    '--------新しくカレンダーを開く前に既存を抹消します。
    Call DeleteCal

    Yobi = Array("", "日", "月", "火", "水", "木", "金", "土")

    '--------シェイプ1ブロックの大きさです。
    shpHeight = 15
    shpWidth = 35

    '--------カレンダーの最も上の位置です。
    TBT = ActiveCell.Offset(0, 1).Top

    '--------カレンダーの1列目の左の位置です
    BL(1) = ActiveCell.Offset(0, 1).Left

    '--------曜日のトップの位置です。
    YBT = TBT + shpHeight

    '--------日付の1段目の位置です。
    DBT(1) = YBT + shpHeight

    '--------2段目以降の位置です
    For I = 2 To 6
        DBT(I) = DBT(I - 1) + shpHeight
    Next I

    '--------日付の2列以降の左端の位置です。
    For J = 2 To 7
        BL(J) = BL(J - 1) + shpWidth
    Next J

    Application.ScreenUpdating = False

    '--------シェイプを作成します。
    Call UpShapes

    '--------カレンダーを描画します。
    Call OpenDraw

    Application.ScreenUpdating = True

End Sub
'---------------------------------------
'
Private Sub UpShapes()
    Dim SHP                 As Shape
    Dim Row                 As Long
    Dim Col                 As Long
    Dim intLogicalDay       As Long
    Dim Grid                As Long

    '--------カレンダーの1行目を描画します。
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(1), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_PreviousYear"
        .OnAction = "ShapeCalendar.PreviousYearClick"
        .Fill.ForeColor.RGB = RGB(252, 213, 181)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = "▼"
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(2), _
                                 TBT, shpWidth * 2, shpHeight)
    With SHP
        .Name = "SHP_TextYaer"
        .OnAction = "ShapeCalendar.Dummy"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = ""
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(4), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_NextYear"
        .OnAction = "ShapeCalendar.NextYearClick"
        .Fill.ForeColor.RGB = RGB(146, 246, 166)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = "▲"
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(5), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_PreviousMonth"
        .OnAction = "ShapeCalendar.PreviousMonthClick"
        .Fill.ForeColor.RGB = RGB(252, 213, 181)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = "▼"
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(6), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_TextMonth"
        .OnAction = "ShapeCalendar.Dummy"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = ""
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(7), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_NextMonth"
        .OnAction = "ShapeCalendar.NextMonthClick"
        .Fill.ForeColor.RGB = RGB(146, 246, 166)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = "▲"
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    '--------曜日の行を描画します。
    For Col = 1 To 7
        intLogicalDay = (((Col - 1) + (FirstYobi - 1)) Mod 7) + 1
        Set SHP = ActiveSheet.Shapes.AddShape(1, BL(Col), _
                                     YBT, shpWidth, shpHeight)
        With SHP
            .Name = "SHPY" & Format(Col, "00")
            .OnAction = "ShapeCalendar.Dummy"
            .Fill.ForeColor.RGB = RGB(221, 221, 221)
            With .TextFrame2
                .MarginTop = 0
                With .TextRange
                    .Text = Yobi(intLogicalDay)
                    .Font.Size = 10
                    If intLogicalDay = 1 Then
                        .Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
                    ElseIf intLogicalDay = 7 Then
                        .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                    Else
                        .Font.Fill.ForeColor.RGB = ColorWeekday
                    End If
                End With
            End With
        End With
        Call ShapeHyozi(SHP)
    Next Col

    '--------日にちを描画します。
    For Row = 1 To 6
        For Col = 1 To 7
            Set SHP = ActiveSheet.Shapes.AddShape(1, BL(Col), _
                                  DBT(Row), shpWidth, shpHeight)
            Grid = Col + (Row - 1) * 7
            With SHP
                .OnAction = "ShapeCalendar.DateClick"
                .Name = "SHPD" & Format(Grid, "00")
                .Fill.ForeColor.RGB = RGB(221, 221, 221)
                With .TextFrame2
                    .MarginTop = 2
                    'Text の描画等は DaysInMonth で行います。
                End With
            End With
            Call ShapeHyozi(SHP)
        Next Col
    Next Row

    '--------最終行を描画します。
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(1), _
                          DBT(6) + shpHeight, shpWidth * 2, shpHeight)
    With SHP
        .Name = "SHP_HOME"
        .OnAction = "ShapeCalendar.GoHome"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 1
            With .TextRange
                .Text = "HOME"
                .Font.Fill.ForeColor.RGB = ColorSaturday
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(3), _
                          DBT(6) + shpHeight, shpWidth * 2, shpHeight)
    With SHP
        .Name = "SHP_PREHOME"
        .OnAction = "ShapeCalendar.GoPreHome"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 1
            With .TextRange
                .Text = "preHOME"
                .Font.Fill.ForeColor.RGB = ColorPreHome
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)

    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(5), _
                          DBT(6) + shpHeight, shpWidth * 3, shpHeight)
    With SHP
        .Name = "SHP_CANCEL"
        .OnAction = "ShapeCalendar.DeleteCal"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 1
            With .TextRange
                .Text = "CANCEL"
                .Font.Fill.ForeColor.RGB = ColorSunday
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)

End Sub
'---------------------------------------
'
Private Sub ShapeHyozi(ByRef myShape As Shape)

    With myShape
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = RGB(166, 166, 166)
        .Line.Weight = 0.5
        .Fill.Visible = msoTrue
        .Fill.Solid
        .Placement = xlFreeFloating
        .Locked = msoTrue
        With .TextFrame2
            .HorizontalAnchor = msoAnchorCenter
            With .TextRange
            .ParagraphFormat.Alignment = msoAlignCenter
            End With
        End With
    End With
    
End Sub
'---------------------------------------
'
Private Sub NextYearClick()
    Call NextYear
End Sub
'---------------------------------------
'
Private Sub PreviousYearClick()
    Call PreviousYear
End Sub
'---------------------------------------
'
Private Sub NextMonthClick()
    Call NextMonth
End Sub
'---------------------------------------
'
Private Sub PreviousMonthClick()
    Call PreviousMonth
End Sub
'---------------------------------------
'
Public Sub NextYear()
    Call IncChageDraw(IntvYear, IncForward)
End Sub
'---------------------------------------
'
Public Sub PreviousYear()
    Call IncChageDraw(IntvYear, IncBackward)
End Sub
'---------------------------------------
'
Public Sub NextMonth()
    Call IncChageDraw(IntvMonth, IncForward)
End Sub
'---------------------------------------
'
Public Sub PreviousMonth()
    Call IncChageDraw(IntvMonth, IncBackward)
End Sub
'---------------------------------------
'
Private Sub IncChageDraw(ByVal intvMove As String, _
                         ByVal DT As IncFlg)
    Dim IncDate             As Date
    Dim iInc                As Long
    Dim Grid                As Long

    '--------インクリメントの方向を決めます。
    If DT = IncForward Then
        iInc = 1
    Else
        iInc = -1
    End If

    '--------インクリメントした日付を求めます。
    IncDate = DateAdd(intvMove, iInc, CurDate)

    '--------表示年月日（CurDate/CurDay..）をセットします。
    Call StartValues(IncDate)

    '--------年と月を表示します。
    Call DrawYearMonth

    '--------日にちを描画します。
    '        DaysAndWeeks の更新が必要
    Call DaysDraw

    '--------黄色を戻します。
    With ActiveSheet.Shapes(SelectShape)
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
    End With

    '--------日にち（CurDay）を黄色に塗ります。
    Call YellwPaint

End Sub
'---------------------------------------
'
Private Sub MoveToToday(ByVal UseCurYear As Boolean)

    '--------戻る日付を求めます。
    If UseCurYear Then
        CurYear = HoldYear
    End If
    CurMonth = HoldMonth
    CurDay = HoldDay
    CurDate = DateSerial(CurYear, CurMonth, CurDay)

    '--------年と月を表示します。
    Call DrawYearMonth

    '--------日にちを描画します。
    '        DaysAndWeeks の更新が必要
    Call DaysDraw

    '--------黄色を戻します。
    With ActiveSheet.Shapes(SelectShape)
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
    End With

    '--------日にち（CurDay）を黄色に塗ります。
    Call YellwPaint

End Sub
'---------------------------------------
'
Private Sub DateClick()
    Dim myCaller            As String

    '-----マクロを呼び出したオブジェクトの名前
    myCaller = Application.Caller
   
    '-----シェイプにテキストデータがない
    If Len(ActiveSheet.Shapes(myCaller).TextFrame2.TextRange.Text) = 0 Then
        Exit Sub
    End If

    '--------2回連続でクリックされた場合、決定しアクティブセルに日付をセットします。
    If (SelectShape = myCaller) Then
        ActiveCell.Value = CurDate
        Call DeleteCal
    Else
        '--------新しい選択のシェイプを描画します。
        Call DateClickShape(myCaller)
    End If
 
End Sub
'---------------------------------------
'
Private Sub DateClickShape(ByVal NewSelect As String)
    Dim Grid                As Long

    '--------シェイプの名前から Grid を求めます。
    Grid = Replace(NewSelect, "SHPD", "")

    If CurMonth <> DatePart(IntvMonth, DaysAndWeeks(Grid)) Then

        '--------表示年月日（CurDate/CurDay..）をセットします。
        Call StartValues(DaysAndWeeks(Grid))

        '--------年と月を表示します。
        Call DrawYearMonth

        '--------日にちを描画します。
        '        DaysAndWeeks の更新が必要
        Call DaysDraw

    Else
        '--------一部の更新します。
        CurDate = DaysAndWeeks(Grid)
        CurDay = DatePart(IntvDay, CurDate)

    End If

    '--------黄色を戻します。
    With ActiveSheet.Shapes(SelectShape)
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
    End With

    '--------日にち（CurDay）を黄色に塗ります。
    Call YellwPaint

End Sub
'---------------------------------------
'
Private Sub GoHome()
    Call MoveToToday(UseCurYear:=True)
End Sub
'---------------------------------------
'
Private Sub GoPreHome()
    Call MoveToToday(UseCurYear:=False)
End Sub
'---------------------------------------
'
Private Sub Dummy()

End Sub
'---------------------------------------
'
Private Sub OpenDraw()
    Dim BUF                 As String
    Dim Grid                As Long

    '--------カレンダーを呼び出したセルの値を取得します。
    BUF = Replace(StrConv(ActiveCell.Value, vbNarrow), ".", "/")
    If IsDate(BUF) Then
        HoldDate = CDate(BUF)
    Else
        HoldDate = Date
    End If

    '--------年月日の要素を取り出す
    HoldDay = DatePart(IntvDay, HoldDate)
    HoldMonth = DatePart(IntvMonth, HoldDate)
    HoldYear = DatePart(IntvYear, HoldDate)

    '--------表示年月日（CurDate/CurDay..）をセットします。
    Call StartValues(HoldDate)

    '--------年と月を表示します。
    Call DrawYearMonth

    '--------休日クラスを作成します。
    Set GetYobi = New C_Kyuzitu

    '--------日にちシェイプの名前の Grid に対応するシリアル値を格納する配列を作成します。
    ReDim DaysAndWeeks(1 To 42)

    '--------日にちを描画します。
    Call DaysDraw

    'オープン時の描画で黄色がありません。
    '--------日にち（CurDay）を黄色に塗ります。
    Call YellwPaint

End Sub
'---------------------------------------
'カレンダーの上部に年と月を表示します。
Private Sub StartValues(ByVal OpenDate As Date)

    '表示の日付をセットします。
    CurDate = OpenDate
    CurYear = DatePart(IntvYear, CurDate)
    CurMonth = DatePart(IntvMonth, CurDate)
    CurDay = DatePart(IntvDay, CurDate)

End Sub
'---------------------------------------
'カレンダーの上部に年と月を表示します。
Private Sub DrawYearMonth()

    With ActiveSheet.Shapes("SHP_TextYaer").TextFrame2.TextRange
        .Text = Format(DateSerial(CurYear, CurMonth, 1), "ggge年")
    End With
    
    With ActiveSheet.Shapes("SHP_TextMonth").TextFrame2.TextRange
        .Text = Format(DateSerial(CurYear, CurMonth, 1), "m月")
    End With
    
End Sub
'---------------------------------------
'
Private Sub DaysDraw()
    Dim newSelected         As String
    Dim OneDayYobi          As Long
    Dim OneDaySerial        As Long
    Dim I                   As Long

    '--------月の初めの1日のシリアル値を求めます。
    OneDaySerial = DateSerial(CurYear, CurMonth, 1)

    '--------月の初めの1日の曜日の値（1日の位置）を求めます。
    OneDayYobi = Weekday(OneDaySerial, FirstYobi)
    StartPosi = OneDayYobi

    '--------日にちシェイプに対応した配列にシリアル値を格納します。
    For I = 1 To UBound(DaysAndWeeks)
        DaysAndWeeks(I) = OneDaySerial - OneDayYobi + I
    Next I

    '--------年をセットし、休日を求めます。
    GetYobi.NowYear = CurYear

    '--------日付の描写
    Call DaysInMonth

End Sub
'---------------------------------------
'
Private Sub DaysInMonth()
    Dim Row                 As Long
    Dim Col                 As Long
    Dim Grid                As Long
    Dim SpName              As String

    '--------DateCalendarの日付の描写
    For Row = 1 To 6
        For Col = 1 To 7

            '--------Row/Colポジションにあるシェイプの名前を求めます。
            Grid = Col + (Row - 1) * 7
            SpName = "SHPD" & Format(Grid, "00")

            With ActiveSheet.Shapes(SpName).TextFrame2.TextRange

                '--------Grid に対応するシリアル値から日にち部分を求め表示します。
                .Text = DatePart(IntvDay, DaysAndWeeks(Grid))

                '--------対象月以外のフォントを小さくします。
                If DatePart(IntvMonth, DaysAndWeeks(Grid)) <> CurMonth Then
                    .Font.Size = 8
                Else
                    .Font.Size = 10
                End If

                '--------休日の赤色表示処理
                GetYobi.SetNumDate = DaysAndWeeks(Grid)
                Select Case GetYobi.WeekNum
                Case 1, Shuku, Kokumin, Kanrei, Hurikae
                    .Font.Fill.ForeColor.RGB = ColorSunday
                Case 7
                    .Font.Fill.ForeColor.RGB = ColorSaturday
                Case Else
                    .Font.Fill.ForeColor.RGB = ColorWeekday
                End Select

            End With

        Next Col
    Next Row

End Sub
'---------------------------------------
'
Private Sub YellwPaint()
    Dim Grid                As Long
    Dim SpName              As String

    '--------選択された日にち（シェイプ）の名前を取得します。
    Grid = StartPosi + CurDay - 1
    SpName = "SHPD" & Format(Grid, "00")

    SelectShape = SpName

    With ActiveSheet.Shapes(SpName)
        '--------黄色にします。
        .Fill.ForeColor.RGB = RGB(255, 255, 0)
    End With

End Sub
'---------------------------------------
'
Public Sub DeleteCal()
    Dim SHP()               As String
    Dim Sp                  As Shape
    Dim objRange            As Object
    Dim iCount              As Long
    Dim I                   As Long

    '-----シェイプがなければ終了
    If ActiveSheet.Shapes.Count = 0 Then
        Exit Sub
    End If
    
    '-----名称がSHPから始まるシェイプの拾い上げ
    ReDim SHP(1 To ActiveSheet.Shapes.Count)
    iCount = 0
    For Each Sp In ActiveSheet.Shapes
        If InStr(1, Sp.Name, "SHP") > 0 Then
            iCount = iCount + 1
            SHP(iCount) = Sp.Name
        End If
    Next Sp
    
    '-----なければ終わり
    If iCount = 0 Then
        Exit Sub
    End If

    '-----シェイプの一括削除のため一括選択
    ReDim Preserve SHP(1 To iCount)
    Set objRange = ActiveSheet.Shapes.Range(SHP)
    objRange.Select

    If Not GetYobi Is Nothing Then
        Set GetYobi = Nothing
    End If

    '----一括削除の実行
    objRange.Delete

End Sub

VBエディターの雰囲気

作成中のVBエディターはこんな感じになります。