[ExcelVBA] １ヶ月のカレンダーを表示する

>Blog Top Page >[ExcelVBA] Top Page >[ExcelVBA] プログラミング問題一覧

■お題
１ヶ月表示のカレンダーを作ってみてください。

■解答例
今回は、修正のしやすさを考慮してモジュールをいくつかに分けて(整理しながら)書いてみようと思います。
今回、
MainModule…メインのコードの流れを書く
SubModule…メインのコードから呼ばれる関数や、カレンダーマクロ特有の関数を書く
CommonModule…他のマクロからも活用する機会がありそうな関数
SetModule…設定変数が書いてある変数
SandBoxModule…わからないことや書いたコードのテストを書く
このように分けて書く事であとで修正する際にどこを見ればいいか判断しやすい状態にしておく。

ひとまず、カレンダーの完成図をイメージしてみる。

(※列の幅は、2.5になっています。)


まずは、カレンダーの基準セル(カレンダーの左上の位置)を決めその位置から
相対的にパーツを配置することで変更が簡単にできるようにしておく。

モジュール名：SetModule…(分けてる目的)設定変数をまとめておく。

view plainprint?

1. Public Const BASE_CELL_ROW = 2  
2. Public Const BASE_CELL_COL = 2  

Public Const BASE_CELL_ROW = 2
Public Const BASE_CELL_COL = 2

１行目：カレンダーの左上のセルで行の情報を格納
２行目：カレンダーの左上のセルで列の情報を格納
どの位置に出力するかは、この変数の値をかえればよいと。


次に、日付を表示してみます。
基準(カレンダーの左上)と同じ行で、２列隣の場所に表示することにします。
モジュール名：SubModule…(分けてる目的)メインのコードから呼ばれる関数や、カレンダーマクロ特有の関数を書く

view plainprint?

1. Sub Say_Today()  
2.     Dim r As Long, c As Integer  
3.     r = BASE_CELL_ROW  
4.     c = BASE_CELL_COL  
5.     Cells(r, c + 2) = Date  
6. End Sub  

Sub Say_Today()
    Dim r As Long, c As Integer
    r = BASE_CELL_ROW
    c = BASE_CELL_COL
    Cells(r, c + 2) = Date
End Sub

２行目：行を格納変数、列を格納する変数を用意。行は、65536行まであることからLong型
３行目：基準セルの行を代入
４行目：基準セルの列を代入
５行目：基準セルと同じ行、２つ列を移動したとこに日付を表示


ここで、考察。
今後、関数を書くたびに行と列を格納する変数を用意し、
それぞれ毎回初期化するたびに、お決まりの２行を書くことになるので
ちょっとでも楽するために１行で代入が済ませれるよう工夫してみる。


上記コードがこうなる。
モジュール名：SetModule…(分けてる目的)設定変数をまとめておく

view plainprint?

1. Sub InitBaseCell(ByRef r As Long, ByRef c As Integer)  
2.     r = BASE_CELL_ROW  
3.     c = BASE_CELL_COL  
4. End Sub  
5.   
6. Sub Say_Today()  
7.     Dim r As Long, c As Integer  
8.     Call InitBaseCell(r, c)  
9.     Cells(r, c + 2) = Date  
10. End Sub  

Sub InitBaseCell(ByRef r As Long, ByRef c As Integer)
    r = BASE_CELL_ROW
    c = BASE_CELL_COL
End Sub

Sub Say_Today()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    Cells(r, c + 2) = Date
End Sub

InitBaseCellという、基準セル位置を初期化する用の関数を用意しました。
これは、参照渡しで値を渡すため、列と行の順番で渡してあげればそちらで代入することになるので
利用する時は、Call InitBaseCellの一行で済ませれます。


想定した挙動になっているか確認
モジュール名：SandBoxModule(分けてる目的)わからないことや書いたコードのテストを書く

view plainprint?

1. Sub t1()  
2.     Dim r As Long, c As Integer  
3.     Call InitBaseCell(r, c)  
4.     Debug.Print "Row:" & r & " Col:" & c  
5. End Sub  

Sub t1()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    Debug.Print "Row:" & r & " Col:" & c
End Sub

特に問題ないですね。



次に、日～土の曜日を表示する関数を追加します。
モジュール名：SetModule…(分けてる目的)設定変数をまとめておく

view plainprint?

1. Sub Say_DayStr()  
2.     Dim r As Long, c As Integer  
3.     Call InitBaseCell(r, c)  
4.     r = r + 1  
5.       
6.     Cells(r, c) = "日"  
7.     Cells(r, c + 1) = "月"  
8.     Cells(r, c + 2) = "火"  
9.     Cells(r, c + 3) = "水"  
10.     Cells(r, c + 4) = "木"  
11.     Cells(r, c + 5) = "金"  
12.     Cells(r, c + 6) = "土"  
13. End Sub  

Sub Say_DayStr()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    r = r + 1
    
    Cells(r, c) = "日"
    Cells(r, c + 1) = "月"
    Cells(r, c + 2) = "火"
    Cells(r, c + 3) = "水"
    Cells(r, c + 4) = "木"
    Cells(r, c + 5) = "金"
    Cells(r, c + 6) = "土"
End Sub

２行目：行を格納変数、列を格納する変数を用意。行は、65536行まであることからLong型
３行目：行と列変数に基準セルの行と列の値を代入
４行目：基準セルの一段下に表示したいので１加算しておく
６行～１２行目：日～土を代入。


ここまでで、ちゃんと表示されるかテストしてみます。
モジュール名：SandBoxModule(分けてる目的)わからないことや書いたコードのテストを書く

view plainprint?

1. Sub t2()  
2.     'Show_Today関数のテスト  
3.     Call Say_Today  
4.     Call Say_DayStr  
5. End Sub  

Sub t2()
    'Show_Today関数のテスト
    Call Say_Today
    Call Say_DayStr
End Sub

こうなった。

(※列の幅は、2.5になっています。)

日付部分は、セルの範囲が狭いのできちんと表示されてないですけど
セルの結合等で適切なサイズのセルを用意すれば問題ないですね。
見た目の調整については、いつやっても問題ないことに関しては極力最後かつ１箇所の関数にまとめておきます。
修正する際にあちこちにちらばっているとさがすのが大変だからです。



次に、日にちを表示する関数を追加してみます。１日からその月の最終日をFor文でぐるぐる回しながら
表示していけばよさそうですね。ここで最終日を取得する関数も作ることにします。この関数は
他のマクロでも使えそうなので、CommonModuleにまとめておきます。
では、コードはこんな感じ。
モジュール名：SubModule…(分けてる目的)メインのコードから呼ばれる関数や、カレンダーマクロ特有の関数を書く

view plainprint?

1. Sub Say_Day()  
2.     Dim r As Long, c As Integer  
3.     Call InitBaseCell(r, c)  
4.       
5.     Dim d As Integer  
6.     r = BASE_CELL_ROW + 2  
7.     For d = 1 To LastDay()  
8.         c = BASE_CELL_COL + Weekday(DateSerial(Year(Date), Month(Date), d)) - 1  
9.         Cells(r, c) = d  
10.         If Weekday(DateSerial(Year(Date), Month(Date), d)) = 7 Then r = r + 1  
11.     Next  
12. End Sub  

Sub Say_Day()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    
    Dim d As Integer
    r = BASE_CELL_ROW + 2
    For d = 1 To LastDay()
        c = BASE_CELL_COL + Weekday(DateSerial(Year(Date), Month(Date), d)) - 1
        Cells(r, c) = d
        If Weekday(DateSerial(Year(Date), Month(Date), d)) = 7 Then r = r + 1
    Next
End Sub

モジュール名：SubModule内
２行目：行を格納変数、列を格納する変数を用意。行は、65536行まであることからLong型
３行目：行と列変数に基準セルの行と列の値を代入
５行目：For文で使う変数ｄ(日にち部分を格納)を宣言
６行目：日にちは、基準セル(カレンダーの左上)より２つ下の行にかくことにします
７行目：For文　初期値は、日付なので１日。TOは、その月の最後の日付。LastDayという関数を別途作る。

先にLastDay関数について
関数の目的として、他のマクロから利用しやすくするために
ある日付をあたえるとその月の最後の日にちを返すということにします。
引数は、省略可能で省略すると今月の最後の日付を返すことにします。
最終日を求めるのに、まず次の月の１日の日付を調べ、
その前日の日付を割り出すことで最終日を求めることにします。

モジュール名：CommonModule…(分けてる目的)他のマクロでも使えそうな関数

view plainprint?

1. Function LastDay(Optional UserDate As Date) As Integer  
2.     Dim SetDate As Date  
3.       
4.     If UserDate Then  
5.         SetDate = UserDate  
6.     Else  
7.         SetDate = Date  
8.     End If  
9.       
10.     Dim NextMonthFirstDate As Date '次の月の１日の日付を格納  
11.     NextMonthFirstDate = DateSerial(Year(SetDate), Month(SetDate) + 1, 1)  
12.      
13.     Dim LastDate As Date 'SetDate日付の最後の日付を格納  
14.     LastDate = DateAdd("d", -1, NextMonthFirstDate)  
15.       
16.     LastDay = Day(LastDate)  
17. End Function  

Function LastDay(Optional UserDate As Date) As Integer
    Dim SetDate As Date
    
    If UserDate Then
        SetDate = UserDate
    Else
        SetDate = Date
    End If
    
    Dim NextMonthFirstDate As Date '次の月の１日の日付を格納
    NextMonthFirstDate = DateSerial(Year(SetDate), Month(SetDate) + 1, 1)
   
    Dim LastDate As Date 'SetDate日付の最後の日付を格納
    LastDate = DateAdd("d", -1, NextMonthFirstDate)
    
    LastDay = Day(LastDate)
End Function

モジュール名：CommonModule内
１行目：引数は省略可能ということでOptionalキーワードをつけてます。
２行目：SetDateという変数を宣言します。(この変数の日付の最後の日を返す)
４行目：If文でオプション用の引数に値があるかチェック
５行目：値がある時は、引数をSetDateに格納
６行目：引数がない時
７行目：今日の日付を格納
１０行目：NextMonthFirstDateを宣言。
１１行目：DateSerial関数を使って、setDateに入っている日付の次の月の１日の日付を代入する
１３行目：SetDateに格納されている日付の最後の日付を格納する変数を宣言
１４行目：次の月の１日の日付(NextMonthFirstDate)からDateAdd関数で１日戻ることで目的の最終日を求める
１６行目：最終的に、Day関数で日にちを取り出して返す


じゃ、ちゃんと動くかテストしてみます。
モジュール名：SandBoxModule(分けてる目的)わからないことや書いたコードのテストを書く

view plainprint?

1. Sub t5()  
2.     Debug.Print LastDay()  
3.     Debug.Print LastDay(CDate("2010/2/10"))  
4.     Debug.Print ""  
5. End Sub  

Sub t5()
    Debug.Print LastDay()
    Debug.Print LastDay(CDate("2010/2/10"))
    Debug.Print ""
End Sub

ちゃんと動いていますね。


SetModuleのFor文に戻ります。
＜再掲＞
モジュール名：SubModule…(分けてる目的)メインのコードから呼ばれる関数や、カレンダーマクロ特有の関数を書く

view plainprint?

1. Sub Say_Day()  
2.     Dim r As Long, c As Integer  
3.     Call InitBaseCell(r, c)  
4.       
5.     Dim d As Integer  
6.     r = BASE_CELL_ROW + 2  
7.     For d = 1 To LastDay()  
8.         c = BASE_CELL_COL + Weekday(DateSerial(Year(Date), Month(Date), d)) - 1  
9.         Cells(r, c) = d  
10.         If Weekday(DateSerial(Year(Date), Month(Date), d)) = 7 Then r = r + 1  
11.     Next  
12. End Sub  

Sub Say_Day()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    
    Dim d As Integer
    r = BASE_CELL_ROW + 2
    For d = 1 To LastDay()
        c = BASE_CELL_COL + Weekday(DateSerial(Year(Date), Month(Date), d)) - 1
        Cells(r, c) = d
        If Weekday(DateSerial(Year(Date), Month(Date), d)) = 7 Then r = r + 1
    Next
End Sub

改めてFor文の中身を解説します。
行と列の特定方法は、列は、Weekday関数を使うことで１～７の値を返してくれるので
基準セルの列　＋ Weekday関数の返す値(1～7) - 1(補正値)
例えば、日曜日はWeekday関数で１を返すので基準セルと同じ列に表示するには、
Weekday関数の返す値から１ひかないと合わなくなります。
補正値と書いているのは、そういうことです。

行に関しては、Weekday関数の値を監視して土曜日だったら、日付表示後に行の変数の値を１つ増やせばいいですね。
８行目：列を求める
９行目：日にちを表示
１０行目：表示した日が土曜日だったら、行の変数の値を１つ加算して次の行へ移動する
１１行目：繰り返し


ここらへんで、カレンダーを表示するための関数としてmainという
名前の関数を用意して今までのコードを実行してみます。
モジュール名：MainModule…(分けてる目的)SubModuleに書いた関数を組み合わせカレンダーを作成する

view plainprint?

1. Sub main()  
2.     Call Say_Today  
3.     Call Say_DayStr  
4.     Call Say_Day  
5. End Sub  

Sub main()
    Call Say_Today
    Call Say_DayStr
    Call Say_Day
End Sub

シンプルで見通しがよいですね。
２行目：今日の日付を表示
３行目：曜日（日～土）を表示
４行目：１ヶ月文の日にちを表示

(※列の幅は、2.5になっています。)

データを書き込む部分は、これでおしまいですね。
あとは、見た目部分を調整していきます。
見た目は、いつ設定しても問題ないものについては最後に一つの関数内にまとめることにします。
モジュール名：SubModule…(分けてる目的)メインのコードから呼ばれる関数や、カレンダーマクロ特有の関数を書く

view plainprint?

1. Sub View()  
2.     Dim BaseR As Long, BaseC As Integer  
3.     Call InitBaseCell(BaseR, BaseC)  
4.       
5.     '日付部分処理  
6.     Range(Cells(BaseR, BaseC + 2), Cells(BaseR, BaseC + 4)).Merge  
7.     With Cells(BaseR, BaseC + 2)  
8.         .Font.Size = 8  
9.         .Font.Bold = True  
10.         .HorizontalAlignment = xlCenter  
11.     End With  
12.       
13.     '曜日部分処理  
14.     Range(Cells(BaseR + 1, BaseC), Cells(BaseR + 1, BaseC + 6)).HorizontalAlignment = xlCenter  
15.   
16.     '土曜日を青色  
17.     Range(Cells(BaseR + 1, BaseC + 6), Cells(BaseR + 6, BaseC + 6)).Font.ColorIndex = 5  
18.       
19.     '日曜日を赤色  
20.     Range(Cells(BaseR + 1, BaseC), Cells(CalendarEndRow(), BaseC)).Font.ColorIndex = 3  
21.   
22.     '全体に関する設定  
23.     With Range(Cells(BaseR + 1, BaseC), Cells(CalendarEndRow(), BaseC + 6))  
24.         .Borders(xlEdgeLeft).LineStyle = xlContinuous  
25.         .Borders.ColorIndex = 56  
26.     End With  
27.       
28.     With Range(Cells(BaseR, BaseC), Cells(CalendarEndRow(), BaseC + 6))  
29.         .Interior.ColorIndex = 19  
30.         .Font.Bold = True  
31.         .Borders(xlEdgeLeft).Weight = xlMedium  
32.         .Borders(xlEdgeLeft).ColorIndex = 56  
33.         .Borders(xlEdgeBottom).Weight = xlMedium  
34.         .Borders(xlEdgeBottom).ColorIndex = 56  
35.         .Borders(xlEdgeRight).Weight = xlMedium  
36.         .Borders(xlEdgeRight).ColorIndex = 56  
37.         .Borders(xlEdgeTop).Weight = xlMedium  
38.         .Borders(xlEdgeTop).ColorIndex = 56  
39.     End With  
40.       
41.     '本日のセルの色を変える  
42.     Dim r As Integer  
43.     r = 2  
44.     Do  
45.         If Cells(BaseR + r, BaseC + Weekday(Date) - 1) = Day(Date) Then  
46.             Cells(BaseR + r, BaseC + Weekday(Date) - 1).Interior.ColorIndex = 35  
47.             Exit Do  
48.         End If  
49.         r = r + 1  
50.     Loop  
51. End Sub  

Sub View()
    Dim BaseR As Long, BaseC As Integer
    Call InitBaseCell(BaseR, BaseC)
    
    '日付部分処理
    Range(Cells(BaseR, BaseC + 2), Cells(BaseR, BaseC + 4)).Merge
    With Cells(BaseR, BaseC + 2)
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    
    '曜日部分処理
    Range(Cells(BaseR + 1, BaseC), Cells(BaseR + 1, BaseC + 6)).HorizontalAlignment = xlCenter

    '土曜日を青色
    Range(Cells(BaseR + 1, BaseC + 6), Cells(BaseR + 6, BaseC + 6)).Font.ColorIndex = 5
    
    '日曜日を赤色
    Range(Cells(BaseR + 1, BaseC), Cells(CalendarEndRow(), BaseC)).Font.ColorIndex = 3

    '全体に関する設定
    With Range(Cells(BaseR + 1, BaseC), Cells(CalendarEndRow(), BaseC + 6))
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders.ColorIndex = 56
    End With
    
    With Range(Cells(BaseR, BaseC), Cells(CalendarEndRow(), BaseC + 6))
        .Interior.ColorIndex = 19
        .Font.Bold = True
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeLeft).ColorIndex = 56
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeBottom).ColorIndex = 56
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlEdgeRight).ColorIndex = 56
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeTop).ColorIndex = 56
    End With
    
    '本日のセルの色を変える
    Dim r As Integer
    r = 2
    Do
        If Cells(BaseR + r, BaseC + Weekday(Date) - 1) = Day(Date) Then
            Cells(BaseR + r, BaseC + Weekday(Date) - 1).Interior.ColorIndex = 35
            Exit Do
        End If
        r = r + 1
    Loop
End Sub

表示部分なので、ざくざく軽く説明していきます。
ここらへんは、マクロの記録で調べつつ余分なとこは省いたコードをのっけていってますね。
２行目：今まで他の関数ではrとcという変数を用意して作業してたのですがrとcはそれ自身の値を
書き換えて使っていたので、書き換えずに使うという意図を含めてBaseRとBaseCという変数にしました。
３行目：行と列変数に基準セルの行と列の値を代入

６行目～１１行目
・日付部分のセル範囲がせまくて##になっているのでD～F列を結合して広くします。
・文字サイズは、８に変更
・太文字フォントに変更

１４行目：曜日のセルをセンタリングします
１７行目：土曜日の列を青色文字へ変更
２０行目：日曜日の列を赤色文字へ変更

２３行目～２６行目：曜日より下の行と列に罫線をひきます。細線です
２８行目～３９行目：
・カレンダー全体に対し背景色を薄い黄色に変更
・太文字へ変更
・カレンダーの四辺を太線罫線で表示

４２行目～５０行目：本日のセルの色を変える
列は、Weekday関数と基準セル列があればわかりあとはDoループで今日の
日にちと一致するセルを探し見つかり次第セルの色を変えてます


上記コード内で、カレンダーの最後の行を取得する関数(CalendarEndRow)を作って使ってます。
２０、２３、２８行目です。
モジュール名：SubModule…(分けてる目的)メインのコードから呼ばれる関数や、カレンダーマクロ特有の関数を書く

view plainprint?

1. Function CalendarEndRow() As Long  
2.     Dim r As Long, c As Integer  
3.     Call InitBaseCell(r, c)  
4.       
5.     Dim UsedCell As Integer  
6.     UsedCell = LastDay() + Weekday(DateSerial(Year(Date), Month(Date), 1)) - 1  
7.     r = BASE_CELL_ROW + 1 + Int(UsedCell / 7)  
8.     If 0 < (UsedCell / 7 - Int(UsedCell / 7)) Then r = r + 1  
9.     CalendarEndRow = r  
10. End Function  

Function CalendarEndRow() As Long
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    
    Dim UsedCell As Integer
    UsedCell = LastDay() + Weekday(DateSerial(Year(Date), Month(Date), 1)) - 1
    r = BASE_CELL_ROW + 1 + Int(UsedCell / 7)
    If 0 < (UsedCell / 7 - Int(UsedCell / 7)) Then r = r + 1
    CalendarEndRow = r
End Function

main関数にView関数の呼び出しを追加して実行してみます。 モジュール名：MainModule…(分けてる目的)SubModuleに書いた関数を組み合わせカレンダーを作成する

view plainprint?

1. Sub main()  
2.     Call Say_Today  
3.     Call Say_DayStr  
4.     Call Say_Day  
5.     Call View  
6. End Sub  

Sub main()
    Call Say_Today
    Call Say_DayStr
    Call Say_Day
    Call View
End Sub

(※列の幅は、2.5になっています。) 最後の仕上げ。 月をまたぐと始まりの日の曜日や最終日がかわるので表示が残っているとおかしなことになります。 加えて、当日のセルは緑色に変更しているので毎日緑のセルがふえていくことになってしまうので 最初に初期化するコードを挟んでおきます。 基準セル位置から８行７列を削除してます。 モジュール名：SubModule…(分けてる目的)メインのコードから呼ばれる関数や、カレンダーマクロ特有の関数を書く

view plainprint?

1. Sub init()  
2.     Dim r As Long, c As Integer  
3.     Call InitBaseCell(r, c)  
4.     Range(Cells(r, c), Cells(r + 7, c + 8)).Clear  
5. End Sub  

Sub init()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    Range(Cells(r, c), Cells(r + 7, c + 8)).Clear
End Sub

そして、main関数にこの関数を追加すると完成です。 モジュール名：MainModule…(分けてる目的)SubModuleに書いた関数を組み合わせカレンダーを作成する

view plainprint?

1. Sub main()  
2.     Call init  
3.     Call Say_Today  
4.     Call Say_DayStr  
5.     Call Say_Day  
6.     Call View  
7. End Sub  

Sub main()
    Call init
    Call Say_Today
    Call Say_DayStr
    Call Say_Day
    Call View
End Sub

最後に全コードを改めて掲載しておきます。 ◆モジュール名：SetModule

view plainprint?

1. Option Explicit  
2.   
3. Public Const BASE_CELL_ROW = 2  
4. Public Const BASE_CELL_COL = 2  

Option Explicit

Public Const BASE_CELL_ROW = 2
Public Const BASE_CELL_COL = 2

◆モジュール名：MainModule

view plainprint?

1. Option Explicit  
2.   
3. Sub main()  
4.     Call init  
5.     Call Say_Today  
6.     Call Say_DayStr  
7.     Call Say_Day  
8.     Call View  
9. End Sub  

Option Explicit

Sub main()
    Call init
    Call Say_Today
    Call Say_DayStr
    Call Say_Day
    Call View
End Sub

◆モジュール名：SubMocule

view plainprint?

1. Option Explicit  
2.   
3. Sub Say_Today()  
4.     Dim r As Long, c As Integer  
5.     Call InitBaseCell(r, c)  
6.     Cells(r, c + 2) = Date  
7. End Sub  
8.   
9. Sub Say_DayStr()  
10.     Dim r As Long, c As Integer  
11.     Call InitBaseCell(r, c)  
12.     r = r + 1  
13.       
14.     Cells(r, c) = "日"  
15.     Cells(r, c + 1) = "月"  
16.     Cells(r, c + 2) = "火"  
17.     Cells(r, c + 3) = "水"  
18.     Cells(r, c + 4) = "木"  
19.     Cells(r, c + 5) = "金"  
20.     Cells(r, c + 6) = "土"  
21. End Sub  
22.   
23. Sub Say_Day()  
24.     Dim r As Long, c As Integer  
25.     Call InitBaseCell(r, c)  
26.       
27.     Dim d As Integer  
28.     r = BASE_CELL_ROW + 2  
29.     For d = 1 To LastDay()  
30.         c = BASE_CELL_COL + Weekday(DateSerial(Year(Date), Month(Date), d)) - 1  
31.         Cells(r, c) = d  
32.         If Weekday(DateSerial(Year(Date), Month(Date), d)) = 7 Then r = r + 1  
33.     Next  
34. End Sub  
35.   
36. Sub View()  
37.     Dim BaseR As Long, BaseC As Integer  
38.     Call InitBaseCell(BaseR, BaseC)  
39.       
40.     '日付部分処理  
41.     Range(Cells(BaseR, BaseC + 2), Cells(BaseR, BaseC + 4)).Merge  
42.     With Cells(BaseR, BaseC + 2)  
43.         .Font.Size = 8  
44.         .Font.Bold = True  
45.         .HorizontalAlignment = xlCenter  
46.     End With  
47.       
48.     '曜日部分処理  
49.     Range(Cells(BaseR + 1, BaseC), Cells(BaseR + 1, BaseC + 6)).HorizontalAlignment = xlCenter  
50.   
51.     '土曜日を青色  
52.     Range(Cells(BaseR + 1, BaseC + 6), Cells(BaseR + 6, BaseC + 6)).Font.ColorIndex = 5  
53.       
54.     '日曜日を赤色  
55.     Range(Cells(BaseR + 1, BaseC), Cells(CalendarEndRow(), BaseC)).Font.ColorIndex = 3  
56.   
57.     '全体設定  
58.     '背景色を設定  
59.     With Range(Cells(BaseR + 1, BaseC), Cells(CalendarEndRow(), BaseC + 6))  
60.         .Borders(xlEdgeLeft).LineStyle = xlContinuous  
61.         .Borders.ColorIndex = 56  
62.     End With  
63.       
64.     With Range(Cells(BaseR, BaseC), Cells(CalendarEndRow(), BaseC + 6))  
65.         .Interior.ColorIndex = 19  
66.         .Font.Bold = True  
67.         .Borders(xlEdgeLeft).Weight = xlMedium  
68.         .Borders(xlEdgeLeft).ColorIndex = 56  
69.         .Borders(xlEdgeBottom).Weight = xlMedium  
70.         .Borders(xlEdgeBottom).ColorIndex = 56  
71.         .Borders(xlEdgeRight).Weight = xlMedium  
72.         .Borders(xlEdgeRight).ColorIndex = 56  
73.         .Borders(xlEdgeTop).Weight = xlMedium  
74.         .Borders(xlEdgeTop).ColorIndex = 56  
75.     End With  
76.       
77.     '本日のセルの色を返る  
78.     Dim r As Integer  
79.     r = 2  
80.     Do  
81.         Debug.Print Cells(BaseR + r, BaseC + Weekday(Date) - 1)  
82.         If Cells(BaseR + r, BaseC + Weekday(Date) - 1) = Day(Date) Then  
83.             Cells(BaseR + r, BaseC + Weekday(Date) - 1).Interior.ColorIndex = 35  
84.             Exit Do  
85.         End If  
86.         r = r + 1  
87.     Loop  
88. End Sub  
89.   
90. Sub init()  
91.     Dim r As Long, c As Integer  
92.     Call InitBaseCell(r, c)  
93.     Range(Cells(r, c), Cells(r + 7, c + 8)).Clear  
94. End Sub  
95.   
96. Function CalendarEndRow() As Long  
97.     Dim r As Long, c As Integer  
98.     Call InitBaseCell(r, c)  
99.       
100.     Dim UsedCell As Integer  
101.     UsedCell = LastDay() + Weekday(DateSerial(Year(Date), Month(Date), 1)) - 1  
102.     r = BASE_CELL_ROW + 1 + Int(UsedCell / 7)  
103.     If 0 < (UsedCell / 7 - Int(UsedCell / 7)) Then r = r + 1  
104.     CalendarEndRow = r  
105. End Function  
106.   
107. Sub InitBaseCell(ByRef r As Long, ByRef c As Integer)  
108.     r = BASE_CELL_ROW  
109.     c = BASE_CELL_COL  
110. End Sub  

Option Explicit

Sub Say_Today()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    Cells(r, c + 2) = Date
End Sub

Sub Say_DayStr()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    r = r + 1
    
    Cells(r, c) = "日"
    Cells(r, c + 1) = "月"
    Cells(r, c + 2) = "火"
    Cells(r, c + 3) = "水"
    Cells(r, c + 4) = "木"
    Cells(r, c + 5) = "金"
    Cells(r, c + 6) = "土"
End Sub

Sub Say_Day()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    
    Dim d As Integer
    r = BASE_CELL_ROW + 2
    For d = 1 To LastDay()
        c = BASE_CELL_COL + Weekday(DateSerial(Year(Date), Month(Date), d)) - 1
        Cells(r, c) = d
        If Weekday(DateSerial(Year(Date), Month(Date), d)) = 7 Then r = r + 1
    Next
End Sub

Sub View()
    Dim BaseR As Long, BaseC As Integer
    Call InitBaseCell(BaseR, BaseC)
    
    '日付部分処理
    Range(Cells(BaseR, BaseC + 2), Cells(BaseR, BaseC + 4)).Merge
    With Cells(BaseR, BaseC + 2)
        .Font.Size = 8
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    
    '曜日部分処理
    Range(Cells(BaseR + 1, BaseC), Cells(BaseR + 1, BaseC + 6)).HorizontalAlignment = xlCenter

    '土曜日を青色
    Range(Cells(BaseR + 1, BaseC + 6), Cells(BaseR + 6, BaseC + 6)).Font.ColorIndex = 5
    
    '日曜日を赤色
    Range(Cells(BaseR + 1, BaseC), Cells(CalendarEndRow(), BaseC)).Font.ColorIndex = 3

    '全体設定
    '背景色を設定
    With Range(Cells(BaseR + 1, BaseC), Cells(CalendarEndRow(), BaseC + 6))
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders.ColorIndex = 56
    End With
    
    With Range(Cells(BaseR, BaseC), Cells(CalendarEndRow(), BaseC + 6))
        .Interior.ColorIndex = 19
        .Font.Bold = True
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeLeft).ColorIndex = 56
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeBottom).ColorIndex = 56
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlEdgeRight).ColorIndex = 56
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeTop).ColorIndex = 56
    End With
    
    '本日のセルの色を返る
    Dim r As Integer
    r = 2
    Do
        Debug.Print Cells(BaseR + r, BaseC + Weekday(Date) - 1)
        If Cells(BaseR + r, BaseC + Weekday(Date) - 1) = Day(Date) Then
            Cells(BaseR + r, BaseC + Weekday(Date) - 1).Interior.ColorIndex = 35
            Exit Do
        End If
        r = r + 1
    Loop
End Sub

Sub init()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    Range(Cells(r, c), Cells(r + 7, c + 8)).Clear
End Sub

Function CalendarEndRow() As Long
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    
    Dim UsedCell As Integer
    UsedCell = LastDay() + Weekday(DateSerial(Year(Date), Month(Date), 1)) - 1
    r = BASE_CELL_ROW + 1 + Int(UsedCell / 7)
    If 0 < (UsedCell / 7 - Int(UsedCell / 7)) Then r = r + 1
    CalendarEndRow = r
End Function

Sub InitBaseCell(ByRef r As Long, ByRef c As Integer)
    r = BASE_CELL_ROW
    c = BASE_CELL_COL
End Sub

◆モジュール名：CommonModule

view plainprint?

1. Option Explicit  
2.   
3. Function LastDay(Optional UserDate As Date) As Integer  
4.     Dim SetDate As Date  
5.       
6.     If UserDate Then  
7.         SetDate = UserDate  
8.     Else  
9.         SetDate = Date  
10.     End If  
11.       
12.     Dim NextMonthFirstDate As Date '来月１日の日付  
13.     NextMonthFirstDate = DateSerial(Year(SetDate), Month(SetDate) + 1, 1)  
14.      
15.     Dim LastDate As Date '今月最後の日付  
16.     LastDate = DateAdd("d", -1, NextMonthFirstDate)  
17.       
18.     LastDay = Day(LastDate)  
19. End Function  

Option Explicit

Function LastDay(Optional UserDate As Date) As Integer
    Dim SetDate As Date
    
    If UserDate Then
        SetDate = UserDate
    Else
        SetDate = Date
    End If
    
    Dim NextMonthFirstDate As Date '来月１日の日付
    NextMonthFirstDate = DateSerial(Year(SetDate), Month(SetDate) + 1, 1)
   
    Dim LastDate As Date '今月最後の日付
    LastDate = DateAdd("d", -1, NextMonthFirstDate)
    
    LastDay = Day(LastDate)
End Function

◆モジュール名：SandBox

view plainprint?

1. Option Explicit  
2.   
3. Sub t1()  
4.     Dim r As Long, c As Integer  
5.     Call InitBaseCell(r, c)  
6.     Debug.Print "Row:" & r & " Col:" & c  
7. End Sub  
8.   
9. Sub t2()  
10.     'Show_Today関数のテスト  
11.     Call Say_Today  
12.     Call Say_DayStr  
13. End Sub  
14.   
15. Sub t3()  
16.     Dim yyyymmdd As Date  
17.     yyyymmdd = DateSerial(Year(Date), Month(Date), 1)  
18.     Debug.Print yyyymmdd  
19.     Debug.Print Weekday(yyyymmdd) '1=>日,7=>土  
20.     Debug.Print ""  
21. End Sub  
22.   
23. Sub t4()  
24.     Dim today As Date  
25.     today = Date  
26.     Debug.Print "本日の日付　　：" & today  
27.       
28.     Dim NextMonthFirstDate As Date  
29.     NextMonthFirstDate = DateSerial(Year(Date), Month(Date) + 1, 1)  
30.     Debug.Print "来月１日の日付：" & NextMonthFirstDate  
31.       
32.     Dim LastDate As Date  
33.     LastDate = DateAdd("d", -1, NextMonthFirstDate)  
34.     Debug.Print "今月最後の日付：" & LastDate  
35.       
36.     Dim LastDay As Integer  
37.     LastDay = Day(LastDate)  
38.     Debug.Print "今月の最後の日：" & LastDay  
39.     Debug.Print ""  
40. End Sub  
41.   
42. Sub t5()  
43.     Debug.Print LastDay()  
44.     Debug.Print LastDay(CDate("2010/2/10"))  
45.     Debug.Print ""  
46. End Sub  
47.   
48. Sub t6()  
49.     Static num As Integer  
50.     num = num + 1  
51.     Debug.Print num  
52. End Sub  

Option Explicit

Sub t1()
    Dim r As Long, c As Integer
    Call InitBaseCell(r, c)
    Debug.Print "Row:" & r & " Col:" & c
End Sub

Sub t2()
    'Show_Today関数のテスト
    Call Say_Today
    Call Say_DayStr
End Sub

Sub t3()
    Dim yyyymmdd As Date
    yyyymmdd = DateSerial(Year(Date), Month(Date), 1)
    Debug.Print yyyymmdd
    Debug.Print Weekday(yyyymmdd) '1=>日,7=>土
    Debug.Print ""
End Sub

Sub t4()
    Dim today As Date
    today = Date
    Debug.Print "本日の日付　　：" & today
    
    Dim NextMonthFirstDate As Date
    NextMonthFirstDate = DateSerial(Year(Date), Month(Date) + 1, 1)
    Debug.Print "来月１日の日付：" & NextMonthFirstDate
    
    Dim LastDate As Date
    LastDate = DateAdd("d", -1, NextMonthFirstDate)
    Debug.Print "今月最後の日付：" & LastDate
    
    Dim LastDay As Integer
    LastDay = Day(LastDate)
    Debug.Print "今月の最後の日：" & LastDay
    Debug.Print ""
End Sub

Sub t5()
    Debug.Print LastDay()
    Debug.Print LastDay(CDate("2010/2/10"))
    Debug.Print ""
End Sub

Sub t6()
    Static num As Integer
    num = num + 1
    Debug.Print num
End Sub

>Blog Top Page >[ExcelVBA] Top Page >[ExcelVBA] プログラミング問題一覧