サンプルマクロは、新規にカレンダーを作成します。
Option Explicit
Dim mySht(1 To 12) As Worksheet
Dim intYear As Integer
Sub Sample()
Dim myMonth As Byte
Dim strYear As String
Dim myDate As Date, myDay As Integer
Dim my2ndMonday As Integer, myEquinox As Integer
On Error Resume Next
Do
strYear = InputBox("カレンダーを作成する年を入力してください。" _
, , Year(Now))
If strYear = vbNullString Then Exit Sub
If Right(strYear, 1) = "年" Then _
strYear = Left(strYear, Len(strYear) - 1)
Err.Clear
intYear = Year(strYear & "/1/1")
Loop Until Err.Number = 0
Application.ScreenUpdating = False
For myMonth = 1 To 12
Set mySht(myMonth) = Sheets(myMonth)
If Err.Number <> 0 Then
Set mySht(myMonth) = Sheets.Add(, Sheets(Sheets.Count))
Err.Clear
End If
mySht(myMonth).Name = myMonth & "月"
Next
mySht(1).Activate
For myMonth = 1 To 12
With mySht(myMonth)
.Cells.Clear
myDay = 1
myDate = intYear & "/" & myMonth & "/" & myDay
While Month(myDate) = myMonth
With .Cells(myDay, 1)
.Value = myDay
.Offset(, 1).Value = _
Left(WeekdayName(Weekday(myDate)), 1)
Select Case Weekday(myDate)
Case vbSunday
.Offset(, 1).Font.Color = RGB(255, 0, 0)
Case vbSaturday
.Offset(, 1).Font.Color = RGB(0, 0, 255)
End Select
End With
myDate = DateAdd("d", 1, myDate)
myDay = Day(myDate)
Wend
End With
Next
'国民の祝日が必要ない場合はこれ以降はコメントアウトしてください。
myFete 1, 1, "元旦"
If intYear < 2000 Then
myFete 1, 15, "成人の日"
Else
my2ndMonday = Get2ndMonday(Weekday(intYear & "/1/1"))
myFete 1, my2ndMonday, "成人の日"
End If
myFete 2, 11, "建国記念日"
myEquinox = Int(21.46758 + 0.242194 * (intYear - 1900) _
- Int((intYear - 1900) / 4))
myFete 3, myEquinox, "春分の日" '誤差のある可能性あり
myFete 4, 29, "みどりの日"
myFete 5, 3, "憲法記念日"
myFete 5, 5, "子供の日"
myFete 7, 20, "海の日"
myFete 9, 15, "敬老の日"
myEquinox = Int(23.87328 + 0.242194 * (intYear - 1900) _
- Int((intYear - 1900) / 4))
myFete 9, myEquinox, "秋分の日" '誤差のある可能性あり
If intYear < 2000 Then
myFete 10, 10, "体育の日"
Else
my2ndMonday = Get2ndMonday(Weekday(intYear & "/10/1"))
myFete 10, my2ndMonday, "体育の日"
End If
myFete 11, 3, "文化の日"
myFete 11, 23, "勤労感謝の日"
myFete 12, 23, "天皇誕生日"
With mySht(5).Cells(4, 2)
If .Characters(1, 1).Font.Color <> RGB(255, 0, 0) Then
myFete 5, 4, "国民の休日"
.Replace "祝", "休"
.Characters(2).Font.ColorIndex = xlAutomatic
End If
End With
Application.ScreenUpdating = True
End Sub
Function Get2ndMonday(my1stWeekday As Long) As Long
Select Case my1stWeekday
Case vbSunday, vbMonday
Get2ndMonday = 10 - my1stWeekday
Case Else
Get2ndMonday = 17 - my1stWeekday
End Select
End Function
Sub myFete(myFeteMonth As Integer, myFeteDay As Integer _
, myFeteName As String)
Dim myDate As Date
Dim f As Boolean
Dim myMonth As Integer, myDay As Integer
myDate = intYear & "/" & myFeteMonth & "/" & myFeteDay
f = True
If Weekday(myDate) = vbSunday Then
myDate = DateAdd("d", 1, myDate)
myMonth = Month(myDate)
myDay = Day(myDate)
f = False
End If
With mySht(myFeteMonth).Cells(myFeteDay, 2)
.Value = .Value & "(祝)"
.Characters(1, 1).Font.Color = RGB(255, 0, 0)
.Characters(2).Font.ColorIndex = xlAutomatic
.Offset(, 1).Value = myFeteName
End With
If f Then Exit Sub
With mySht(myMonth).Cells(myDay, 2)
.Value = .Value & "(休)"
.Characters(1, 1).Font.Color = RGB(255, 0, 0)
.Characters(2).Font.ColorIndex = xlAutomatic
.Offset(, 1).Value = "振替休日"
End With
End Sub
'Excel2000ではこれ以降は不要です。
Function WeekDayName(myDay As Integer) As String
Dim myWeekDayName As Variant
myWeekDayName = _
Array("日", "月", "火", "水", "木", "金", "土")
WeekDayName = myWeekDayName(myDay - 1)
'WeekDayName = WeekDayName & "曜日"
End Function
