Option Explicit
Private Const TARGET_SHEET_PREFIX As String = "Calendar"
Private Const HOLIDDAY_BACK_COLOR As Long = vbRed
Private Const HOLIDDAY_FORE_COLOR As Long = vbWhite
Private Const REFERENCE_ROW As Long = 2
Private Const REFERENCE_COL As Long = 2
Private Const HEADER_ROWS As Long = 3
Private Const LINE_SPACING_MONTH As Long = 2
Private Const COLUMN_SPACING_MONTH As Long = 2
Private Const LINE_SPACING_DAY As Long = 1
Private Const COLUMN_SPACING_DAY As Long = 1
Private Const MONTHS_IN_LINE As Long = 3
Private Enum CalendarPrintMode
enm01To12
enm04To03
End Enum
Private Const CALENDAR_COL_WIDTH As Double = 3.25
Private Const CALENDER_ROW_HEIGHT As Double = 14.25
Private Const REFERENCE_ROW_V As Long = 2
Private Const REFERENCE_COL_V As Long = 1
Private Const CALENDER_V_DATE_COL_INDEX As Long = 0
Private Const CALENDER_V_WEEKDAY_COL_INDEX As Long = 1
Private Const CALENDER_V_HOLIDAY_NAME_COL_INDEX As Long = 2
Public Sub createCalendarY(ByVal lYear As Long)
Dim ws As Worksheet
Dim r As Range
Dim cch As CCompanyHoliday
Dim i As Long
Set ws = getTargetSheet(lYear)
Set cch = New CCompanyHoliday
For i = 1 To 12
Set r = getReferenceRange(ws, i, enm01To12)
Call createCalendarSub(cch, r, lYear, i)
Next i
Set cch = Nothing
Debug.Print "Done."
End Sub
Public Sub createCalendarYD(ByVal lYear As Long)
Dim ws As Worksheet
Dim r As Range
Dim cch As CCompanyHoliday
Dim i As Long
Set ws = getTargetSheet(lYear)
Set cch = New CCompanyHoliday
For i = 4 To 12
Set r = getReferenceRange(ws, i, enm04To03)
Call createCalendarSub(cch, r, lYear, i)
Next i
For i = 1 To 3
Set r = getReferenceRange(ws, i, enm04To03)
Call createCalendarSub(cch, r, lYear + 1, i)
Next i
Set cch = Nothing
Debug.Print "Done."
End Sub
Public Sub createCalendarYMV(ByVal lYear As Long, _
ByVal lBeginMonth As Long, _
ByVal lMonthes As Long, _
Optional ByVal printHolidayName As Boolean = False)
Dim ws As Worksheet
Dim r As Range
Dim cch As CCompanyHoliday
Dim i As Long
Set ws = getTargetSheet(lYear)
Set r = ws.Cells(REFERENCE_ROW_V, REFERENCE_COL_V)
Set cch = New CCompanyHoliday
Call createCalendarVSub(cch, r, lYear, lBeginMonth, lMonthes, printHolidayName)
Set cch = Nothing
Debug.Print "Done."
End Sub
Private Function getTargetSheet(ByVal lYear As Long) As Worksheet
Dim ws As Worksheet
Dim s As Worksheet
Dim sSheetName As String
sSheetName = TARGET_SHEET_PREFIX & CStr(lYear)
For Each s In ThisWorkbook.Worksheets
If s.Name = sSheetName Then
Set ws = ThisWorkbook.Worksheets(sSheetName)
With ws
.Range(.Cells(1, 1), .Cells(.Rows.Count, .Columns.Count)).Clear
End With
Exit For
End If
Next s
If ws Is Nothing Then
With ThisWorkbook.Worksheets
Set ws = .Add(after:=ThisWorkbook.Worksheets(.Count))
End With
ws.Name = sSheetName
End If
With ws.Cells
.ColumnWidth = CALENDAR_COL_WIDTH
.RowHeight = CALENDER_ROW_HEIGHT
End With
Set getTargetSheet = ws
End Function
Private Sub createCalendarSub(ByRef cch As CCompanyHoliday, _
ByRef r As Range, _
ByVal lYear As Long, _
ByVal lMonth As Long)
Dim dtBegin As Date
Dim dtEnd As Date
Dim dtDate As Date
Dim lDays As Long
Dim lRowIndex As Long
Dim lColIndex As Long
Dim lRowOffset As Long
Dim lColOffset As Long
Dim i As Long
Const WEEKDAYS As String = "日月火水木金土"
dtBegin = DateSerial(lYear, lMonth, 1)
dtEnd = DateSerial(lYear, lMonth + 1, 0)
r.Value = StrConv(CStr(lMonth), vbWide) & "月"
lRowOffset = HEADER_ROWS - 1
For i = 0 To 6
lColOffset = i * (COLUMN_SPACING_DAY + 1)
r.Offset(lRowOffset, lColOffset).Value = Mid$(WEEKDAYS, i + 1, 1)
Next i
lRowIndex = 0
lColIndex = Weekday(dtBegin) - vbSunday
With r
For i = 0 To Day(dtEnd) - 1
lRowOffset = lRowIndex * (LINE_SPACING_DAY + 1) + HEADER_ROWS
lColOffset = lColIndex * (COLUMN_SPACING_DAY + 1)
.Offset(lRowOffset, lColOffset).Value = i + 1
dtDate = DateAdd("d", i, dtBegin)
If cch.isCompanyHoliday(dtDate) Then
.Offset(lRowOffset, lColOffset).Interior.Color = HOLIDDAY_BACK_COLOR
.Offset(lRowOffset, lColOffset).Font.Color = HOLIDDAY_FORE_COLOR
End If
lColIndex = lColIndex + 1
If lColIndex Mod 7 = 0 Then
lColIndex = 0
lRowIndex = lRowIndex + 1
End If
Next i
End With
End Sub
Private Sub createCalendarVSub(ByRef cch As CCompanyHoliday, _
ByRef r As Range, _
ByVal lYear As Long, _
ByVal lBeginMonth As Long, _
ByVal lMonthes As Long, _
ByVal printHolidayName As Boolean)
Dim dtBegin As Date
Dim dtEnd As Date
Dim dtDate As Date
Dim lDays As Long
Dim sHolidayName As String
Dim i As Long
Const WEEKDAYS As String = "日月火水木金土"
dtBegin = DateSerial(lYear, lBeginMonth, 1)
dtEnd = DateSerial(lYear, lBeginMonth + lMonthes, 0)
lDays = DateDiff("d", dtBegin, dtEnd) + 1
With r
For i = 0 To lDays - 1
dtDate = DateAdd("d", i, dtBegin)
.Offset(i, CALENDER_V_DATE_COL_INDEX).Value = dtDate
.Offset(i, CALENDER_V_WEEKDAY_COL_INDEX).Value = Mid$(WEEKDAYS, Weekday(dtDate), 1)
If cch.isCompanyHoliday2(dtDate, sHolidayName) Then
.Offset(i, CALENDER_V_WEEKDAY_COL_INDEX).Interior.Color = HOLIDDAY_BACK_COLOR
.Offset(i, CALENDER_V_WEEKDAY_COL_INDEX).Font.Color = HOLIDDAY_FORE_COLOR
If printHolidayName Then
.Offset(i, CALENDER_V_HOLIDAY_NAME_COL_INDEX).Value = sHolidayName
End If
End If
Next i
.Offset(0, CALENDER_V_DATE_COL_INDEX).EntireColumn.AutoFit
.Offset(0, CALENDER_V_WEEKDAY_COL_INDEX).EntireColumn.AutoFit
If printHolidayName Then
.Offset(0, CALENDER_V_HOLIDAY_NAME_COL_INDEX).EntireColumn.AutoFit
End If
End With
End Sub
Private Function getReferenceRange(ByRef ws As Worksheet, _
ByVal lMonth As Long, _
ByVal lPrintMode As CalendarPrintMode) As Range
Const MAX_WEEKS_IN_MONTH As Long = 6
Dim lLinesInMonth As Long
Dim lColsInMonth As Long
Dim lMonthW As Long
Dim lNthV As Long
Dim lNthH As Long
Dim lRow As Long
Dim lCol As Long
lLinesInMonth = HEADER_ROWS + MAX_WEEKS_IN_MONTH + (MAX_WEEKS_IN_MONTH - 1) * LINE_SPACING_DAY
If lPrintMode = CalendarPrintMode.enm04To03 Then
Select Case lMonth
Case 1 To 3
lMonthW = lMonth + 9
Case 4 To 12
lMonthW = lMonth - 3
End Select
Else
lMonthW = lMonth
End If
lNthV = (lMonthW + MONTHS_IN_LINE - 1) \ MONTHS_IN_LINE
lRow = REFERENCE_ROW + (lNthV - 1) * (lLinesInMonth + LINE_SPACING_MONTH)
lColsInMonth = 7 + (7 - 1) * COLUMN_SPACING_DAY
lNthH = lMonthW Mod MONTHS_IN_LINE
If lNthH Mod MONTHS_IN_LINE = 0 Then
lNthH = MONTHS_IN_LINE
End If
lCol = REFERENCE_COL + (lNthH - 1) * (lColsInMonth + COLUMN_SPACING_MONTH)
Set getReferenceRange = ws.Cells(lRow, lCol)
End Function
モジュール先頭の定数を適当にいじって、いろいろ試してみて下さい。