カレンダーによる日付入力

ユーザーフォームを作って日付入力するにはどうしますか?
以前にダウンロードされた方へ  「ダウンロード」「カレンダー入力用フォーム」を用意しました。
元々、「ダウンロード」に挙げられるようなツールではないと思っているのですが、こちらで紹介したものより若干は実戦的にはなったと思うので、 こちらはコード説明に残しておいて新設させることにしました。 機能としての違いはセルの直下にカレンダーが表示できること、矢印キーで選択日付の移動ができること、祝日名称の表示、さらには祝日パラメータをワークシートで定義できることなどが変更されています。 ソースコードも紹介しており、関心がある方はご覧下さい。
テキストボックスにそのまま「日付」を入力でしょうか。 「ユーザーフォーム上の数値入力や日付入力の工夫」でも説明しましたが、普通のテキストボックス入力でも「月日」を入力したら「年月日」に変換するなどは可能です。 しかし、既存のカレンダー形式のコントロールとなると、「カレンダーコントロール」Accessがインストールされている必要がありますし、Microsoft Date and Time Picker Control 6.0はランタイム環境ではライセンスの問題が発生します。
では、現状のユーザーフォームでの標準機能で実装できる「カレンダー入力フォーム」に作成してみましょう。ついでですから他のコントロールではできない「祝日」表示も実装してみることにします。
実は、この手の「フリーソフト」はいくつか出回っていますが、アドイン化されているため、既存のワークブックに組み込んで配布することはできません。 ですが、ここで紹介する方法は機能を搭載するプロジェクトに「カレンダー入力フォーム」を組み込んでしまうので、その点での不都合はありません。
プログラム修正なく祝日の変更に対応できないか!?   このページの方法では、年間各月の祝日の判定はプログラムソース記述で行なっているのが現状です。 2019年からは、平成天皇の退位や新しい天皇の「天皇誕生日」の祝日設定などで、この数年は祝日判定プログラムを変更する必要が毎年発生するようです。 さらに政府では「五輪特需」的な祝日も検討されているようです。
であれば、このような祝日変更をプログラムの修正なく対応できないものか、と考えたのです。
春分の日、秋分の日は特殊な計算が必要ですが、それ以外の祝日はテーブル登録から計算できないかと考える時期が来ました。
そこで考えたのが「年間カレンダーの作成2」です。営業日数算出のプロシージャも含めてあります。
祝日の定義は「祝日パラメータ」シートで設定するようになっており、会社休日の追加も行なえるようになっています。 このページは「以前の方法のサンプル」として残しますが、日付入力に関してはダウンロードにある「カレンダー入力用フォーム」の方法をご利用下さい。
シート上のセル、又はフォームのテキストボックスに対する日付入力を支援します。
ここで行なう方法は、ワークシート上、あるいはユーザーフォームの上にカレンダー入力専用のユーザーフォームを重ねて表示する方法です。
カレンダー入力のテストブック
(画像をクリックすると、このサンプルがダウンロードできます)
ワークシート上では、A列のセル選択でのイベント処理で、セルに対するカレンダー入力プロシージャが起動されるようになっています。

Aのどれかのセルをクリックしてみると、このように「カレンダー(日付選択)」が表示されます。
A列のセルをクリックすると、カレンダーが表示される。
「カレンダー(日付選択)」の上で所望する日付をクリックすると、シート上の選択されていたセルに選んだ日付が表示されます。

ユーザーフォームの場合は、「ユーザーフォームの起動」をクリックします。
ユーザーフォームを起動したところ。
ユーザーフォームのサンプルは、カレンダーの表示位置制御の説明の都合上、普通に配置したテキストボックスと、フレーム内に配置したテキストボックスを用意していますが、 見ての通り、コンボボックスではないかと思われると思います。ですが、これはテキストボックスです。プロパティの設定(ShowDropButtonWhenプロパティ)によってコンボボックスのようなドロップボタンが表示できます。

このコンボボックスにあるような[▼]をクリックすると、「カレンダー(日付選択)」が表示されます。
テキストボックスの▼でカレンダーが表示される。
このテキストボックスはシート上でも利用できますが、「図形描画」のものではなく「コントロールツールボックス」のものですから注意が必要です。

「親」となるワークシートやユーザーフォームのコードを見てみましょう。
ある程度、汎用的に利用できるように「カレンダー(日付選択)」のユーザーフォーム自身は関連する「祝日判定機能」なども自身に納めており、 また、これとは別に「セル」と「テキストボックス」から呼び出す専用プロシージャを納めた標準モジュールを用意しています。
このカレンダーを利用しようというワークブックでは、この「ユーザーフォーム(FRM_CALENDAR.frm)」と「標準モジュール(FRM_CALENDAR.bas)」をVBプロジェクトにインポートさせて、 以下のサンプルを参考に専用プロシージャ「ShowCalendarFromRange」「ShowCalendarFromTextBox」を呼び出すように記述を変更すれば機能が実現できるはずです。

では、まずはワークシートのイベント記述のサンプルです。

'*******************************************************************************
'   カレンダーフォーム(日付入力部品)    ※シートイベント
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit

'*******************************************************************************
' セル選択によるイベント
'*******************************************************************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 複数セル選択時は無視
    If Target.Count <> 1 Then Exit Sub
    ' A列以外は無視(今回サンプルの例)
    If Target.Column <> 1 Then Exit Sub
    ' カレンダーフォームを起動する
    Call ShowCalendarFromRange(Target)
End Sub

'--------------------------------<< End of Source >>----------------------------

これはイベント動作のプロシージャですから、プロシージャの形式が決まっています。「イベント動作」の最後がシートのイベントでここで利用するものと同じプロシージャです。
ここでは、「A列の単一セル」を条件にしていますが、厳密的な動作は「セルをクリック」そのものではなく、新しいセルが選択された時に発生するイベントを利用しています。 元々、「セルをクリック」に対するイベントが存在しないからの代替策ですが、弊害としては、
  • 選択済みのセルを上からクリックしてもイベントが発生しない。
  • マウスだけでなく、矢印キーで選択セルが移動する場合でもイベントが起きる。
などが挙げられます。これは「我慢」するしかありません。
記述上は見ても分かる通り、「A列の単一セル」の条件判定後は、専用プロシージャ「ShowCalendarFromRange」に選択セルである「Target」を引き渡して呼び出すだけです。 あとは「ShowCalendarFromRange」がセルに日付をセットするところまでやってくれます。
A列ではなく日付入力の特定セルだけで表示させるにはどうするのか」という質問が結構あるのですが、要はTargetで通知われるセルがその特定セルの場合だけカレンダーを表示させる、 つまり条件に合わなければ「Exit Sub」で抜けてしまえば良いだけなのです。

もうひとつは、テキストボックスです。
下記コードは、テスト用に作成したユーザーフォームのコードです。 こちらは、専用プロシージャ「ShowCalendarFromTextBox」を呼び出す際に、テキストボックス自身の他にテキストボックスから判断したフォーム出現の位置情報を引数に渡しています。 セルの場合もそうですが、第一引数以外はオプションとしているので省略することが可能で、位置の指定がない場合はカレンダーフォームは「親」ウィンドウの中央に表示されます。

'*******************************************************************************
'   カレンダーフォーム(日付入力部品)    ※テスト用フォーム
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit
Const g_cnsAddLeft = 2  ' Left調整値
Const g_cnsAddTop = 38  ' Top調整値
Const g_cnsAddLeft2 = 4 ' Left調整値(フレーム用)
Const g_cnsAddTop2 = 45 ' Top調整値(フレーム用)
' ※これらの調整値はWindowsXPの画面で適当に見繕った値です。

'*******************************************************************************
' フォーム上の単純テキストボックス
'*******************************************************************************
Private Sub TextBox1_DropButtonClick()
    Dim lngLeft As Long, lngTop As Long

    ' フォーム+テキストボックスのLeft,Top値から位置を判定
    lngLeft = Me.Left + TextBox1.Left + g_cnsAddLeft
    lngTop = Me.Top + TextBox1.Top + g_cnsAddTop
    ' カレンダーフォームを起動する
    Call ShowCalendarFromTextBox(TextBox1, "", "", lngLeft, lngTop)
End Sub

'*******************************************************************************
' フレーム上の単純テキストボックス
'*******************************************************************************
Private Sub TextBox2_DropButtonClick()
    Dim lngLeft As Long, lngTop As Long

    ' フォーム+フレーム+テキストボックスのLeft,Top値から位置を判定
    lngLeft = Me.Left + Frame1.Left + TextBox2.Left + g_cnsAddLeft2
    lngTop = Me.Top + Frame1.Top + TextBox2.Top + g_cnsAddTop2
    ' カレンダーフォームを起動する
    Call ShowCalendarFromTextBox(TextBox2, "", "", lngLeft, lngTop)
End Sub

'*******************************************************************************
' ユーザーフォームの初期化
'*******************************************************************************
Private Sub UserForm_Initialize()
    ' テキストボックスに▼ボタンを表示させる
    TextBox1.ShowDropButtonWhen = fmShowDropButtonWhenAlways
    TextBox2.ShowDropButtonWhen = fmShowDropButtonWhenAlways
End Sub

'--------------------------------<< End of Source >>----------------------------

テキストボックスの「DropButtonClick」イベントは、まさに[▼]がクリックされた時のイベントなので今回の処理にはうってつけです。 ユーザーフォームでは、フォーム自身、フレーム、テキストボックスの「Left」、「Top」のプロパティからおおよそのカレンダーフォーム位置が判定できるので、 テキストボックスの直下に表示されるようにしてみました。 実際は、取得した「Left」、「Top」のプロパティだけではカレンダーフォームはテキストボックスに重なってしまいます。 これはウィンドウのタイトルバーや「枠」部分が値に反映していないからだと思われます。 この分は適当に増分値を定数として置いて、表示位置を引数に与える段階で加算させるという方法を採っています。
サンプルの値はWindowsXPで画面を見ながら設定したもので、Windows2000とはタイトルバーの高さなどが違うため異なる位置に表示されるかも知れません。

次に、カレンダー表示用の共通記述の標準モジュールです。
ここから先は、単に「カレンダー入力機能」だけを利用しようという方には、呼び出し方だけ理解すれば内容を細かく理解する必要はありませんが、 ユーザーフォームを使うこなす上では初心者の方には多少のアイデアもあると思うので、一通り説明します。
まずは、先ほど説明した「専用プロシージャ」の収容モジュール(FRM_CALENDAR.bas)です。
中には、テキストボックスから呼び出すための「ShowCalendarFromTextBox」と、セルから呼び出すための「ShowCalendarFromRange」があります。 引数には処理する対象オブジェクトであるテキストボックス(MSForms.TextBox)又はセルRangeの他、 オプションとしてカレンダーフォームのタイトル、値をテキストボックスにセットする時の日付フォーマット(テキストボックスのみ)、カレンダーフォームの位置情報(Left,Top)を指定することができます。

'*******************************************************************************
'   カレンダーフォーム(日付入力部品)    ※呼び出しプロシージャ
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit
Private Const cnsDateFormat = "YYYY/MM/DD"  ' デフォルトの日付Format
Private Const cnsCaption = "日付選択"       ' デフォルトのCaption
Public g_swCalendar1Loaded As Boolean       ' Load判定スイッチ

'*******************************************************************************
' ユーザーフォームのテキストボックス(MsForms.TextBox)から表示させる
'*******************************************************************************
' [引数]
'  ・テキストボックス(Object、シートからの場合はコントロールツールボックスの物)
'  ・カレンダーフォームのCaption(String) ※Option、デフォルトは"日付選択"
'  ・値を返す時のFormat(String) ※Option、デフォルトは"YYYY/MM/DD"
'  ・カレンダーフォームの表示位置:横(Long) ※Option
'  ・カレンダーフォームの表示位置:縦(Long) ※Option
'*******************************************************************************
Public Sub ShowCalendarFromTextBox(objTextBox As MSForms.TextBox, _
                                   Optional strCaption As String, _
                                   Optional strFormat As String, _
                                   Optional lngLeft As Long, _
                                   Optional lngTop As Long)
    Dim dteDate As Date

    ' 元となる日付をテキストボックスから取得
    If IsDate(Trim(objTextBox.Text)) Then
        dteDate = CDate(Trim(objTextBox.Text))
    End If
    ' Caption(タイトル)指定がない場合はデフォルト("日付選択")を指定
    If strCaption = "" Then strCaption = cnsCaption
    ' 表示フォーマット指定がない場合はデフォルト("YYYY/MM/DD")を指定
    If strFormat = "" Then strFormat = cnsDateFormat
    ' カレンダーフォーム
    With FRM_CALENDAR
        ' Tagに元日付(シリアル値)をセット
        .Tag = CLng(dteDate)
        ' Captionをセット
        .Caption = strCaption
        ' フォーム表示位置の確認
        If ((lngLeft <> 0) And (lngTop <> 0)) Then
            ' 指定がある場合はマニュアル指定
            .StartUpPosition = 0
            .Left = lngLeft
            .Top = lngTop
        Else
            ' 指定がない場合はオーナーフォームの中央
            .StartUpPosition = 1
        End If
        ' カレンダーフォームを表示
        .Show
        ' フォームがUnloadされた場合は以降の処理を無視する
        On Error Resume Next
        ' Tagの日付を確認
        If IsNumeric(.Tag) <> True Then Exit Sub
        If Err.Number <> 0 Then Exit Sub
        On Error GoTo 0
        ' Tagから選択日付を取り出してテキストボックスにセット
        dteDate = CDate(.Tag)
        objTextBox.Text = Format(dteDate, strFormat)
    End With
End Sub

'*******************************************************************************
' セル(Range)から表示させる
'*******************************************************************************
' [引数]
'  ・セル(Object) ※原則として単一セル
'  ・カレンダーフォームのCaption(String) ※Option、デフォルトは"日付選択"
'  ・カレンダーフォームの表示位置:横(Long) ※Option
'  ・カレンダーフォームの表示位置:縦(Long) ※Option
'*******************************************************************************
Public Sub ShowCalendarFromRange(objRange As Range, _
                                 Optional strCaption As String, _
                                 Optional lngLeft As Long, _
                                 Optional lngTop As Long)
    Dim dteDate As Date

    ' 元となる日付をセルから取得
    If IsDate(Trim(objRange.Value)) Then
        dteDate = CDate(Trim(objRange.Value))
    End If
    ' Caption(タイトル)指定がない場合はデフォルト("日付選択")を指定
    If strCaption = "" Then strCaption = cnsCaption
    ' カレンダーフォーム
    With FRM_CALENDAR
        ' Tagに元日付(シリアル値)をセット
        .Tag = CLng(dteDate)
        ' Captionをセット
        .Caption = strCaption
        ' フォーム表示位置の確認
        If ((lngLeft <> 0) And (lngTop <> 0)) Then
            ' 指定がある場合はマニュアル指定
            .StartUpPosition = 0
            .Left = lngLeft
            .Top = lngTop
        Else
            ' 指定がない場合はオーナーフォームの中央
            .StartUpPosition = 1
        End If
        ' カレンダーフォームを表示
        .Show
        ' フォームがUnloadされた場合は以降の処理を無視する
        On Error Resume Next
        ' Tagの日付を確認
        If IsNumeric(.Tag) <> True Then Exit Sub
        If Err.Number <> 0 Then Exit Sub
        On Error GoTo 0
        ' Tagから選択日付を取り出してセルにセット
        dteDate = CDate(.Tag)
        objRange.Value = dteDate
    End With
End Sub

'--------------------------------<< End of Source >>----------------------------

カレンダーフォームとの設定日付のやりとりは、ユーザーフォーム自身の「Tag」プロパティで日付シリアル値で受け渡しています。 これらのプロシージャを使わずに直接カレンダーフォームを扱う場合は、この点に気をつけて下さい。

そして、カレンダーフォームのコードです。まずはイベント部分。
カレンダーフォームは、このようになっています。
ユーザーフォームには7曜×6週のラベルを配置
日付をクリックして日付セット処理を行なう用途ですが、「ボタン(CommandButton)」を並べてしまうといかにも殺風景なフォームになってしまいます。 ユーザーフォームの「ボタン(CommandButton)」にはあまりデザインの幅(色や形状)がないことが問題なので、ここではクリックのイベントが問題なく取得できることで「ラベル(Label)」を使います。
フラットなデザインができることはもちろんですが、「ボタン(CommandButton)」のような形状にもなるし、枠や塗りつぶしも自在です。

日付の「ラベル(Label)」は、「昨日」「今日」「明日」を除くと7曜日×6週=42個となります。
ラベル名には規則を持たせ、連番を表意させておく。
クリックなどのイベントの記述は、ユーザーフォームではコントロールを直接配列化できないので42種類作成することになります。 クラスモジュールを使って配列処理を行なうことは可能ですが、42個分クラスも生成されるし、2次利用にクラスモジュールも持ち込むことになるので、 単純に42個のクリックイベントをそのまま記述させています。(1件を1行で書くという「暴挙」に出ています。)

前フリはこのくらいにして、コードを見てみましょう。

'*******************************************************************************
'   カレンダーフォーム(日付入力部品)    ※ユーザーフォーム
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit
Private tblDate(1 To 42) As MSForms.Label       ' 日付ラベル
Private tblDate2(1 To 42) As Date               ' 日付
Private swInit As Boolean                       ' イベント抑止SW
Private g_FormDate1 As Date                     ' 初期日付

'*******************************************************************************
' ■フォーム上のイベント
'*******************************************************************************
' 「年」コンボのイベント
'*******************************************************************************
Private Sub CBO_YEAR_Change()
    ' カレンダー作成
    Call GP_MakeCalendar
End Sub

'*******************************************************************************
' 「月」コンボのイべント
'*******************************************************************************
Private Sub CBO_MONTH_Change()
    ' カレンダー作成
    Call GP_MakeCalendar
End Sub

'*******************************************************************************
' 「Cancel」ボタン(非表示)のイべント
'*******************************************************************************
Private Sub CMD_CANCEL_Click()
    Me.Hide
End Sub

'*******************************************************************************
' 各日付ラベルのイベント(クラス処理はしないでそれぞれClickイベントで受ける)
'*******************************************************************************
' 各日付ラベル(7曜×6週=42件、対応日付は表示時点で配列化されている)
Private Sub LBL_01_Click(): Call GP_ClickCalendar(tblDate2(1)):  End Sub
Private Sub LBL_02_Click(): Call GP_ClickCalendar(tblDate2(2)):  End Sub
Private Sub LBL_03_Click(): Call GP_ClickCalendar(tblDate2(3)):  End Sub
Private Sub LBL_04_Click(): Call GP_ClickCalendar(tblDate2(4)):  End Sub
Private Sub LBL_05_Click(): Call GP_ClickCalendar(tblDate2(5)):  End Sub
Private Sub LBL_06_Click(): Call GP_ClickCalendar(tblDate2(6)):  End Sub
Private Sub LBL_07_Click(): Call GP_ClickCalendar(tblDate2(7)):  End Sub
Private Sub LBL_08_Click(): Call GP_ClickCalendar(tblDate2(8)):  End Sub
Private Sub LBL_09_Click(): Call GP_ClickCalendar(tblDate2(9)):  End Sub
Private Sub LBL_10_Click(): Call GP_ClickCalendar(tblDate2(10)): End Sub
Private Sub LBL_11_Click(): Call GP_ClickCalendar(tblDate2(11)): End Sub
Private Sub LBL_12_Click(): Call GP_ClickCalendar(tblDate2(12)): End Sub
Private Sub LBL_13_Click(): Call GP_ClickCalendar(tblDate2(13)): End Sub
Private Sub LBL_14_Click(): Call GP_ClickCalendar(tblDate2(14)): End Sub
Private Sub LBL_15_Click(): Call GP_ClickCalendar(tblDate2(15)): End Sub
Private Sub LBL_16_Click(): Call GP_ClickCalendar(tblDate2(16)): End Sub
Private Sub LBL_17_Click(): Call GP_ClickCalendar(tblDate2(17)): End Sub
Private Sub LBL_18_Click(): Call GP_ClickCalendar(tblDate2(18)): End Sub
Private Sub LBL_19_Click(): Call GP_ClickCalendar(tblDate2(19)): End Sub
Private Sub LBL_20_Click(): Call GP_ClickCalendar(tblDate2(20)): End Sub
Private Sub LBL_21_Click(): Call GP_ClickCalendar(tblDate2(21)): End Sub
Private Sub LBL_22_Click(): Call GP_ClickCalendar(tblDate2(22)): End Sub
Private Sub LBL_23_Click(): Call GP_ClickCalendar(tblDate2(23)): End Sub
Private Sub LBL_24_Click(): Call GP_ClickCalendar(tblDate2(24)): End Sub
Private Sub LBL_25_Click(): Call GP_ClickCalendar(tblDate2(25)): End Sub
Private Sub LBL_26_Click(): Call GP_ClickCalendar(tblDate2(26)): End Sub
Private Sub LBL_27_Click(): Call GP_ClickCalendar(tblDate2(27)): End Sub
Private Sub LBL_28_Click(): Call GP_ClickCalendar(tblDate2(28)): End Sub
Private Sub LBL_29_Click(): Call GP_ClickCalendar(tblDate2(29)): End Sub
Private Sub LBL_30_Click(): Call GP_ClickCalendar(tblDate2(30)): End Sub
Private Sub LBL_31_Click(): Call GP_ClickCalendar(tblDate2(31)): End Sub
Private Sub LBL_32_Click(): Call GP_ClickCalendar(tblDate2(32)): End Sub
Private Sub LBL_33_Click(): Call GP_ClickCalendar(tblDate2(33)): End Sub
Private Sub LBL_34_Click(): Call GP_ClickCalendar(tblDate2(34)): End Sub
Private Sub LBL_35_Click(): Call GP_ClickCalendar(tblDate2(35)): End Sub
Private Sub LBL_36_Click(): Call GP_ClickCalendar(tblDate2(36)): End Sub
Private Sub LBL_37_Click(): Call GP_ClickCalendar(tblDate2(37)): End Sub
Private Sub LBL_38_Click(): Call GP_ClickCalendar(tblDate2(38)): End Sub
Private Sub LBL_39_Click(): Call GP_ClickCalendar(tblDate2(39)): End Sub
Private Sub LBL_40_Click(): Call GP_ClickCalendar(tblDate2(40)): End Sub
Private Sub LBL_41_Click(): Call GP_ClickCalendar(tblDate2(41)): End Sub
Private Sub LBL_42_Click(): Call GP_ClickCalendar(tblDate2(42)): End Sub
' 昨日、今日、明日ラベル
Private Sub LBL_YESTERDAY_Click(): Call GP_ClickCalendar(Date - 1): End Sub
Private Sub LBL_TODAY_Click():     Call GP_ClickCalendar(Date):     End Sub
Private Sub LBL_TOMORROW_Click():  Call GP_ClickCalendar(Date + 1): End Sub

'*******************************************************************************
' 年月スピンボタンのイベント
'*******************************************************************************
Private Sub SPN_MONTH_Change()
    Dim IXM As Integer, IXY As Integer

    ' カレンダー表示後にValueがゼロ復帰するのでその時点のイベント発生は無視
    If SPN_MONTH.Value = 0 Then Exit Sub
    swInit = True                           ' イベント抑止SW-On
    ' 年月コンボの現在表示状態(ListIndex)を取得
    IXM = CBO_MONTH.ListIndex
    IXY = CBO_YEAR.ListIndex
    If SPN_MONTH.Value < 0 Then
        ' 前月(-1) 年月コンボを1ヶ月前に変更
        If IXM > 0 Then
            CBO_MONTH.ListIndex = IXM - 1
        ElseIf IXY > 0 Then
            CBO_YEAR.ListIndex = IXY - 1
            CBO_MONTH.ListIndex = 11
        Else
            Exit Sub
        End If
    Else
        ' 翌月(+1) 年月コンボを1ヶ月後に変更
        If IXM < 11 Then
            CBO_MONTH.ListIndex = IXM + 1
        ElseIf IXY < 6 Then
            CBO_YEAR.ListIndex = IXY + 1
            CBO_MONTH.ListIndex = 0
        Else
            Exit Sub
        End If
    End If
    swInit = False                          ' イベント抑止SW-Off
    ' カレンダー作成
    Call GP_MakeCalendar
End Sub

'*******************************************************************************
' フォーム表示(繰り返し表示の場合はHideのみのためInitializeは起きない)
'*******************************************************************************
Private Sub UserForm_Activate()
    Dim intY As Integer, intM As Integer, IX As Integer

    ' Tagから日付を取り出す
    g_FormDate1 = CDate(Me.Tag)
    ' Tagは非数値状態にしておく
    Me.Tag = False
    ' 初期の年月をセット
    If g_FormDate1 = 0 Then g_FormDate1 = Date
    intY = Year(g_FormDate1)                ' 年
    intM = Month(g_FormDate1)               ' 月
    swInit = True                           ' イベント抑止SW-On
    ' 「年」をコンボにセット
    For IX = 0 To 6
        If CInt(Trim(CBO_YEAR.List(IX))) = intY Then Exit For
    Next IX
    If IX <= 6 Then CBO_YEAR.ListIndex = IX
    ' 「月」をコンボにセット
    For IX = 0 To 11
        If CInt(Trim(CBO_MONTH.List(IX))) = intM Then Exit For
    Next IX
    If IX <= 11 Then CBO_MONTH.ListIndex = IX
    swInit = False                          ' イベント抑止SW-Off
    ' カレンダー作成
    Call GP_MakeCalendar
End Sub

'*******************************************************************************
' フォーム初期化(繰り返し表示の場合はHideのみのためInitializeは起きない)
'*******************************************************************************
Private Sub UserForm_Initialize()
    Dim IX As Integer, IX_E As Integer
    Dim strName As String

    swInit = True                           ' イベント抑止SW-On
    ' 年コンボにリストをセット(システム日当年+前後3カ年)
    With CBO_YEAR
        .Clear
        IX = Year(Date) - 3
        IX_E = IX + 6
        Do While IX <= IX_E
            .AddItem " " & CStr(IX)
            IX = IX + 1
        Loop
        .ListIndex = 3
    End With
    ' 月コンボにリストをセット(1〜12月、左詰めのため空白を補う)
    With CBO_MONTH
        .Clear
        For IX = 1 To 9
            .AddItem " " & CStr(IX)
        Next IX
        For IX = 10 To 12
            .AddItem CStr(IX)
        Next IX
        IX = Month(Date) - 1
        .ListIndex = IX
    End With
    ' 日付ラベルをObject型配列変数にセット(処理内ではこの変数で値を登録)
    For IX = 1 To 42
        strName = "LBL_" & Format(IX, "00")
        Set tblDate(IX) = Me.Controls(strName)
    Next IX
    g_swCalendar1Loaded = True              ' Load判定スイッチ(⇒Load)
    swInit = False                          ' イベント抑止SW-Off
End Sub

'*******************************************************************************
' フォーム終了
'*******************************************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' 閉じる[×]ボタンが押された時、Unloadされないようにする
    Cancel = True
    Me.Hide
End Sub

Private Sub UserForm_Terminate()
    g_swCalendar1Loaded = False             ' Load判定スイッチ(⇒Unload)
End Sub
コントロールから発生するイベントは、「ラベル(Label)」のクリックイベントの他、「年コンボ(Combobox)」「月コンボ(Combobox)」及び「年月スピンボタンSpinButton」です。
「ラベル(Label)」については、カレンダーの表示時点でどのラベルが何日なのかが明確なので、予め呼び出す処理に引き渡す「日付」をラベル名にある数字と同じ配列に用意しておいてセットしてあります。 このことで「1行書き」が可能なのです。
その他のコントロールは全て表示年月の変更なので、「カレンダー表示処理」を共通プロシージャに集約しておいて、これを呼び出すだけになっています。
フォームの初期化(Initialize)や表示(Activate)も同様ですが、運用上でカレンダーフォームは繰り返し呼び出されると想定できるので、 一回の動作完了時はUnloadせずにHideだけで抜けています。 フォームの初期化(Initialize)では、「年コンボ(Combobox)」「月コンボ(Combobox)」のリストセット(年はシステム日の年+前後3年としている。)と、 各日付の「ラベル(Label)」を配列変数に取得させています。 この「ラベル(Label)」の配列変数は、次の「カレンダー表示処理」で役立つのです。

次は、カレンダーを生成するプロシージャなどです。(ここが「要」です。)
カレンダーは、指定月当月の1日から末日までを曜日位置を合わせて表示させるのですが、実際には初週と末週は前後の月の日付も入ってきます。 ですが、処理はさほど難しくはなく、最初に月初日(1日)の曜日コード(日曜を「1」、土曜を「7」とする値)を取得したら、月初日(1日)の日付から曜日コードを差し引いてしまい、 この日を起点に42回ループを行なうだけの方法です。
「月初日(1日)の日付から曜日コードを差し引く」というのは「日付型」の取り扱いが「シリアル値」であることを積極的に利用するもので、「シリアル値」では1日の増分が整数の「1」なので、 月初日(1日)の日付から曜日コードを差し引いて得られるのは「前週の土曜日の日付」になります。 つまり、ここから「1」ずつ加算しながら42回ループさせれば「7曜日×6週=42件」のカレンダーの要素にあたる日付になるわけです。
しかも、フォームの初期化(Initialize)の段階で、42個の「ラベル(Label)」は配列変数に収まっているので、 ラベル上の処理もこの配列変数に対して行なえば良いわけです。

'*******************************************************************************
' ■共通サブ処理
'*******************************************************************************
' カレンダー表示処理
'*******************************************************************************
Private Sub GP_MakeCalendar()
    Const cnsBC_Select = &HFFC0C0       ' 選択日付の背景色
    Const cnsBC_Month = &H80FFFF        ' 当月の背景色
    Const cnsBC_Other = &H8000000F      ' 当月以外の背景色
    Const cnsFC_Select = &HC000C0       ' 選択日付の文字色
    Const cnsFC_Sunday = &HFF           ' 日曜の文字色
    Const cnsFC_Saturday = &HFF0000     ' 土曜の文字色
    Const cnsFC_Month = &H0             ' 当月の文字色
    Const cnsFC_Other = &H404040        ' 当月以外の文字色
    Dim intYear As Integer, intMonth As Integer
    Dim dteDate As Date, dteDate2 As Date
    Dim intYobi As Integer
    Dim IX As Integer, IXH As Integer, IXH_MAX As Integer
    Dim tblHoli As Variant

    If swInit = True Then Exit Sub              ' イベント抑止SW判定
    intYear = CInt(Trim(CBO_YEAR.Text))         ' 指定年
    intMonth = CInt(Trim(CBO_MONTH.Text))       ' 指定月
    ' 前後3ヶ月の祝日テーブル取得(共通関数より)
    tblHoli = FP_GetHoliTable(intYear, intMonth)
    IXH_MAX = UBound(tblHoli)
    dteDate = DateSerial(intYear, intMonth, 1)  ' 月初日
    intYobi = Weekday(dteDate, vbSunday)        ' 曜日の取得
    ' 指定日付から一旦、前週の最終日(土曜日)に戻す
    dteDate = dteDate - intYobi
    intYobi = 0
    ' 先頭の祝日テーブル位置判定(マッチング利用のため)
    IXH = 0
    dteDate2 = dteDate + 1      ' カレンダー内の初日
    Do While IXH <= IXH_MAX
        If tblHoli(IXH) >= dteDate2 Then Exit Do
        IXH = IXH + 1
    Loop
    ' フォーム上の日付セット(7曜×6週=42件固定)
    For IX = 1 To 42
        ' 当位置の日付、曜日を算出
        intYobi = intYobi + 1
        If intYobi > 7 Then intYobi = 1
        dteDate = dteDate + 1
        ' 日付は別テーブルにセット
        tblDate2(IX) = dteDate
        ' ラベルコントロールを配列化した変数
        With tblDate(IX)
            ' ラベルに日付をセット
            .Caption = Day(dteDate)
            ' 月度、曜日によりラベルの書式をセット
            .Font.Bold = False
            If dteDate = g_FormDate1 Then
                ' 初期選択日付
                .BackColor = cnsBC_Select
                .ForeColor = cnsFC_Select
                .Font.Bold = True
            ElseIf Month(dteDate) = intMonth Then
                ' 当月
                .BackColor = cnsBC_Month
                Select Case intYobi
                    Case 1              ' 日曜日
                        .ForeColor = cnsFC_Sunday
                        .Font.Bold = True
                    Case 7              ' 土曜日
                        .ForeColor = cnsFC_Saturday
                        .Font.Bold = True
                    Case Else: .ForeColor = cnsFC_Month
                End Select
            Else
                ' 当月以外
                .BackColor = cnsBC_Other
                Select Case intYobi
                    Case 1:    .ForeColor = cnsFC_Sunday
                    Case 7:    .ForeColor = cnsFC_Saturday
                    Case Else: .ForeColor = cnsFC_Other
                End Select
            End If
            ' 祝日(含振替休日)の判定
            If IXH <= IXH_MAX Then
                ' 祝日テーブルの日付との一致を判定
                If tblHoli(IXH) = dteDate Then
                    ' 日曜と同様の文字色とする
                    .ForeColor = cnsFC_Sunday
                    If Month(dteDate) = intMonth Then .Font.Bold = True
                    ' 祝日テーブルの参照Indexを加算
                    IXH = IXH + 1
                End If
            End If
        End With
    Next IX
    SPN_MONTH.Value = 0     ' 年月スピンのValueを0に戻す
End Sub

'*******************************************************************************
' カレンダークリック処理
'*******************************************************************************
Private Sub GP_ClickCalendar(dteDate As Date)
    Me.Tag = CLng(dteDate)  ' 現在の選択日付(シリアル値)
    Me.Hide
End Sub

'*******************************************************************************
' 前当翌3ヶ月の祝日テーブルを配列で返す(カレンダーには前後の月が表示されるため)
'*******************************************************************************
Private Function FP_GetHoliTable(intYear As Integer, _
                                 intMonth As Integer) As Variant
    Dim tblHoli As Variant, tblHoli2 As Variant
    Dim intY As Integer, intM As Integer
    Dim IX As Integer, IX1 As Integer, IX2 As Integer, IX3 As Integer

    ' 前月の年月を算出
    If intMonth = 1 Then
        intY = intYear - 1
        intM = 12
    Else
        intY = intYear
        intM = intMonth - 1
    End If
    ' 前・当・翌の3ヶ月を繰り返す
    For IX1 = 1 To 3
        ' 該当月の祝日を配列で受け取る(共通関数)
        tblHoli = FP_GetHoliday(intY, intM)
        If IsArray(tblHoli) = True Then
            ' 受け取った祝日テーブルを別テーブルに接合する
            If IsArray(tblHoli2) = True Then
                IX = UBound(tblHoli)
                IX2 = UBound(tblHoli2)
                ReDim Preserve tblHoli2(IX2 + IX + 1)
                For IX3 = 0 To IX
                    IX2 = IX2 + 1
                    tblHoli2(IX2) = tblHoli(IX3)
                Next IX3
            Else
                tblHoli2 = tblHoli
            End If
        End If
        ' 翌月の年月を算出
        If intM = 12 Then
            intY = intY + 1
            intM = 1
        Else
            intM = intM + 1
        End If
    Next IX1
    FP_GetHoliTable = tblHoli2      ' 戻り値をセット
End Function

'*******************************************************************************
' 当該年月の祝日(振替休日補正後)を配列で返す
'*******************************************************************************
Private Function FP_GetHoliday(intY As Integer, _
                               intM As Integer) As Variant
    Dim tblDate() As Date       ' 祝日の配列
    Dim IX As Long              ' 配列のIndex

    ' 配列の初期化(要素数)
    IX = -1
    ' 月による分岐
    Select Case intM
        '-----------------------------------------------------------------------
        ' 1月
        Case 1
            IX = 1
            ReDim tblDate(IX)
            ' 元旦(1/1)
            tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 1))
            ' 成人の日
            If intY < 2000 Then
                ' 1999年までは15日固定
                tblDate(1) = FP_GetHoliday2(DateSerial(intY, intM, 15))
            Else
                ' 2000年以降は第2月曜日
                tblDate(1) = FP_GetHoliday3(intY, intM, 2, 2)
            End If
        '-----------------------------------------------------------------------
        ' 2月
        Case 2
            IX = 0
            ReDim tblDate(IX)
            ' 建国記念の日(2/11)
            tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 11))
        '-----------------------------------------------------------------------
        ' 3月
        Case 3
            IX = 0
            ReDim tblDate(IX)
            ' 春分の日(※専用処理)
            tblDate(0) = FP_GetSyunbun(intY)
        '-----------------------------------------------------------------------
        ' 4月
        Case 4
            IX = 0
            ReDim tblDate(IX)
            ' みどりの日(4/29) ⇒ 昭和の日(2007年〜)
            tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 29))
        '-----------------------------------------------------------------------
        ' 5月
        Case 5
            If intY >= 1985 Then
                IX = 2
                ReDim tblDate(IX)
                If intY < 2007 Then
                    ' 憲法記念日(5/3)
                    tblDate(0) = DateSerial(intY, intM, 3)
                    ' 国民の休日(5/4)
                    tblDate(1) = DateSerial(intY, intM, 4)
                    ' 子供の日(5/5)
                    tblDate(2) = FP_GetHoliday2(DateSerial(intY, intM, 5))
                Else
                    ' 2007年以降は5/3,5/4が日曜の場合、5/6が振り返られる
                    If Weekday(DateSerial(intY, intM, 3), vbSunday) = 1 Then
                        tblDate(0) = DateSerial(intY, intM, 4)
                        tblDate(1) = DateSerial(intY, intM, 5)
                        tblDate(2) = DateSerial(intY, intM, 6)
                    ElseIf Weekday(DateSerial(intY, intM, 4), vbSunday) = 1 Then
                        tblDate(0) = DateSerial(intY, intM, 3)
                        tblDate(1) = DateSerial(intY, intM, 5)
                        tblDate(2) = DateSerial(intY, intM, 6)
                    Else
                        tblDate(0) = DateSerial(intY, intM, 3)
                        tblDate(1) = DateSerial(intY, intM, 4)
                        tblDate(2) = FP_GetHoliday2(DateSerial(intY, intM, 5))
                    End If
                End If
            Else
                IX = 1
                ReDim tblDate(IX)
                ' 憲法記念日(5/3)
                tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 3))
                ' 子供の日(5/5)
                tblDate(1) = FP_GetHoliday2(DateSerial(intY, intM, 5))
            End If
        '-----------------------------------------------------------------------
        ' 6月
        Case 6
            ' 祝日なし
        '-----------------------------------------------------------------------
        ' 7月
        Case 7
            If intY >= 2003 Then
                ' 海の日(第3月曜日)
                IX = 0
                ReDim tblDate(IX)
                tblDate(0) = FP_GetHoliday3(intY, intM, 3, 2)
            ElseIf intY >= 1996 Then
                ' 海の日(7/20)
                IX = 0
                ReDim tblDate(IX)
                tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 20))
            End If
        '-----------------------------------------------------------------------
        ' 8月
        Case 8
            If intY >= 2016 Then
                ' 山の日(8/11) ※2016年より
                IX = 0
                ReDim tblDate(IX)
                tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 11))
            End If
        '-----------------------------------------------------------------------
        ' 9月
        Case 9
            IX = 1
            ReDim tblDate(IX)
            If intY >= 2003 Then
                ' 敬老の日(第3月曜日)
                tblDate(0) = FP_GetHoliday3(intY, intM, 3, 2)
                ' 秋分の日(※専用処理)
                tblDate(1) = FP_GetSyuubun(intY)
                ' 敬老の日の翌々日が秋分の日の場合、間の日は「国民の休日」になる
                If (tblDate(1) - tblDate(0)) = 2 Then
                    IX = 3
                    ReDim Preserve tblDate(IX)
                    tblDate(2) = tblDate(1)
                    tblDate(1) = tblDate(0) + 1
                End If
            Else
                ' 敬老の日(9/15)
                tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 15))
                ' 秋分の日(※専用処理)
                tblDate(1) = FP_GetSyuubun(intY)
            End If
        '-----------------------------------------------------------------------
        ' 10月
        Case 10
            IX = 0
            ReDim tblDate(IX)
            If intY >= 2000 Then
                ' 体育の日(第2月曜日)
                tblDate(0) = FP_GetHoliday3(intY, intM, 2, 2)
            Else
                ' 体育の日(10/10)
                tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 10))
            End If
        '-----------------------------------------------------------------------
        ' 11月
        Case 11
            IX = 1
            ReDim tblDate(IX)
            ' 文化の日(11/3)
            tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 3))
            ' 勤労感謝の日(11/23)
            tblDate(1) = FP_GetHoliday2(DateSerial(intY, intM, 23))
        '-----------------------------------------------------------------------
        ' 12月
        Case 12
            If intY >= 1989 Then
                IX = 0
                ReDim tblDate(IX)
                ' 天皇誕生日(12/23)
                tblDate(0) = FP_GetHoliday2(DateSerial(intY, intM, 23))
            End If
    End Select
    ' 戻り値のセット(祝日なしはブランク)
    If IX >= 0 Then
        FP_GetHoliday = tblDate
    Else
        FP_GetHoliday = ""
    End If
End Function

'*******************************************************************************
' 当該祝日が日曜なら翌日を返す
'*******************************************************************************
Private Function FP_GetHoliday2(dteHoliday As Date) As Date
    If Weekday(dteHoliday, vbSunday) = 1 Then
        FP_GetHoliday2 = dteHoliday + 1
    Else
        FP_GetHoliday2 = dteHoliday
    End If
End Function

'*******************************************************************************
' 年月第n週のm曜日を算出
'*******************************************************************************
Private Function FP_GetHoliday3(intY As Integer, _
                                intM As Integer, _
                                intW As Integer, _
                                intG As Integer) As Date
    Dim dteDate As Date
    Dim intG2 As Integer

    dteDate = DateSerial(intY, intM, 1)     ' 月初日
    intG2 = Weekday(dteDate, vbSunday)      ' 月初日の曜日
    If intG2 > intG Then intW = intW + 1    ' 初週調整
    FP_GetHoliday3 = dteDate - intG2 + (intW - 1) * 7 + intG
End Function

'*******************************************************************************
' 春分の日の算出
'*******************************************************************************
Private Function FP_GetSyunbun(intY As Integer) As Date
    Dim intD As Integer, intY2 As Integer

    ' 祝日法施行(1947年)以前,2151年以降(簡易計算不可)は無視
    intY2 = intY - 1980
    Select Case intY
        Case Is <= 1979
            intD = Int(20.8357 + (0.242194 * intY2) - Int(intY2 / 4))
        Case Is <= 2099
            intD = Int(20.8431 + (0.242194 * intY2) - Int(intY2 / 4))
        Case Else
            intD = Int(21.851 + (0.242194 * intY2) - Int(intY2 / 4))
    End Select
    FP_GetSyunbun = FP_GetHoliday2(DateSerial(intY, 3, intD))
End Function

'*******************************************************************************
' 秋分の日の算出
'*******************************************************************************
Private Function FP_GetSyuubun(intY As Integer) As Date
    Dim intD As Integer, intY2 As Integer

    ' 祝日法施行(1947年)以前,2151年以降(簡易計算不可)は無視
    intY2 = intY - 1980
    Select Case intY
        Case Is <= 1979
            intD = Int(23.2588 + (0.242194 * intY2) - Int(intY2 / 4))
        Case Is <= 2099
            intD = Int(23.2488 + (0.242194 * intY2) - Int(intY2 / 4))
        Case Else
            intD = Int(24.2488 + (0.242194 * intY2) - Int(intY2 / 4))
    End Select
    FP_GetSyuubun = FP_GetHoliday2(DateSerial(intY, 9, intD))
End Function

'--------------------------------<< End of Source >>----------------------------
この「祝日判定機能」のプロシージャだけでも他の月間カレンダーの処理に利用できるかも知れません。

「ダウンロード」には、DateTimePickerを使った「日付入力のクラス」を紹介しています。 この方法は、「Microsoft Date and Time Picker Control 6.0」をVisual Basic 6.0がインストールされていない環境で使うようなライセンス問題に抵触しない方法なのですが、 プロパティの操作が簡単にできないので表示フォントのコントロールができないなど解明できていないなどの問題があります。
そこへ行くと、こちらの方法は標準のユーザーフォームにあるコントロールだけを使用しているので問題ない上、デザイン面での変更も可能です。 しかも既存のカレンダーコントロールと違って祝日の表現ができる利点もあるので、検討価値はあると思います。
会社独自の休日を追加して表示させたい....  質問で「会社独自の休日を追加して表示させる方法は?」というのを多くいただきます。
この場合は上記のソースコードの「GP_GetHoliday_Sub」プロシージャの中を修正して下さい。 「営業日数の算出」の中のサンプルコードでは12/29〜1/3を会社休日にするというような記述になっており、変更部分は説明のコメントを付けてあります。
なお、「GP_GetHoliday_Sub」プロシージャは祝日名を表示させる機能の有無で記述が異なるのでそのままコピーするのではなく、参考として独自に記述変更させて下さい。