快速创建指定日期带合计的日历表

实例需求：根据用户在B1单元格输入的年份，自动创建日历表，具体要求如下。

• 日历表包含指定年份的全部星期四
• 每个月份首行，在第一列写入月份的英文简称
• 每个月份结束之后，添加月份合计行
• 每个季度结束之后，添加季度合计行
• 所有合计单元格设置格式如下图所示（粗体、填充色、边框）

Option Explicit
Sub Demo()
    Dim i As Long, j As Long
    Dim arrData, rngData As Range, rngTotal As Range
    Dim arrRes(1 To 72, 1 To 2), iR As Long, iMth As Long, sMth As String
    Dim LastRow As Long, iDate As Date, iWK As Long
    Dim oSht As Worksheet
    Const START_ROW = 4
    Set oSht = Sheets("Sheet1")  
    If Len(oSht.Range("B1")) = 0 Or (Not IsNumeric(oSht.Range("B1"))) Then
        MsgBox "Please input Year in cell B1"
        oSht.Range("B1").Select
        Exit Sub
    End If
    LastRow = oSht.Cells(Rows.Count, "B").End(xlUp).Row
    If LastRow >= START_ROW Then oSht.Range(START_ROW & ":" & LastRow).Clear
    iDate = VBA.DateSerial(oSht.Range("B1"), 1, 1)
    iWK = 4 - VBA.Weekday(iDate, vbMonday)
    If iWK < 0 Then iWK = iWK + 7
    iDate = iDate + iWK
    Do
        iR = iR + 1
        If VBA.Month(iDate) > iMth Then
            If iMth > 0 Then
                arrRes(iR, 2) = sMth & " Total"
                Set rngTotal = MergeRng(rngTotal, oSht.Cells(START_ROW + iR - 1, 2))
                iR = iR + 1
                If iMth Mod 3 = 0 Then
                    arrRes(iR, 2) = "Q" & iMth \ 3 & " Total"
                    Set rngTotal = MergeRng(rngTotal, oSht.Cells(START_ROW + iR - 1, 2))
                    iR = iR + 1
                End If
            End If
            iMth = VBA.Month(iDate)
            sMth = Format(VBA.DateSerial(2000, iMth, 1), "MMM")
            arrRes(iR, 1) = sMth
        End If
        arrRes(iR, 2) = iDate
        iDate = iDate + 7
    Loop Until iDate > VBA.DateSerial(Range("B1"), 12, 31)
    iR = iR + 1
    arrRes(iR, 2) = sMth & " Total"
    arrRes(iR + 1, 2) = "Q" & iMth \ 3 & " Total"
    Set rngTotal = MergeRng(rngTotal, oSht.Cells(START_ROW + iR - 1, 2).Resize(2))
    oSht.Cells(START_ROW, 1).Resize(iR + 1, 2).Value = arrRes
    oSht.Range("B" & START_ROW, oSht.Range("B" & START_ROW).End(xlDown)).NumberFormatLocal = "m/d/yyyy"
    If Not rngTotal Is Nothing Then
        With rngTotal
            .Interior.Color = RGB(192, 230, 245)
            .Font.Bold = True
            .HorizontalAlignment = xlHAlignRight
            .Borders.LineStyle = xlContinuous
        End With
    End If
End Sub
Function MergeRng(RngAll As Range, RngSub As Range) As Range
    If RngAll Is Nothing Then
        Set RngAll = RngSub
    Else
        Set RngAll = Application.Union(RngAll, RngSub)
    End If
    Set MergeRng = RngAll
End Function

【代码解析】
第9行代码获取工作表对象。
第10行代码检测单元格B1是否为空，或者包含非数字字符，则第11行代码给出错误提示，第12行代码选中B1单元格，第12行代码结束代码执行。
第15行代码获取B列最后数据所在行号。
第16行代码如果最末行号大于起始行号，那么清空从第4行之后的全部数据，保留第1~3行的表头内容。
第17行代码获取指定年份的第一天。
第18~20行代码使用Weekday计算指定年份第一个星期四的日期，并保存在变量iDate中。
第21~40行代码循环遍历所有的星期四。
第23行代码判断iDate日期所在月份是否大于iMth，如果满足条件，则说明开始了新的一个月份，第25~36行代码将添加月份合计和季度合计行。
第25行代码写入月度合计。
第26行代码保存合计单元格区域，用于后续设置单元格格式。
第28行代码用于判断是否为季度末月份，如果满足条件，第29行代码写入季度合计，第30行代码保存合计单元格区域。
第34行代码更新当前月份iMth。
第35行代码获取月份的英文简写。
第26行代码写入首列月份。
第38行代码填充日期。
第39行代码获取下一个周四日期。
第40行代码在下一个周四超过指定年份之后退出循环。
第42~43行代码写入12合计和四季度合计。
第45行代码将数组写入工作表。
第56行代码设置B列的日期格式。
第47~56行代码设置合计单元格的格式。
第49行代码设置填充颜色。
第50行代码设置字体为粗体。
第51行代码设置水平居中。
第52行代码设置显示边框线。

第56~63行代码为函数MergeRng用于合并两个单元格区域，并返回合并后的Range对象。
第57行代码如果RngAll为空，则第58行代码将RngSub赋值给RngAll，否则第60行代码使用Union函数合并两个单元格区域。