Excel：在电子表格中自动填充每周日期

Question

我有一个如下图所示的电子表格。我创建它的方式是：

1. 我在单元格 B4 中计算当年的每周星期四
2. 然后我将B5中的公式设置为“=B4+7”。
3. 我把它拖下来填满一月的第一个月
4. 然后我从 A4 到 B8 中选择并向下拖动以填充其余月份的表格
5. 最后我插入到季度行。

问题是当新的一年开始时，这可能行不通，特别是如果一年中有 5 周的话。有没有办法做到这一点，如果我更改年份，工作表会根据我正在寻找的内容正确填充这些行，如上所述？

这是我使用上面描述的步骤构建的图像和内容。

编辑：概率并不重要，但公式应引用 B1 的日期。在我当前工作的电子表格中，我也有 O3 单元格。

Answer 1

• VBA 是创建日期表的选项

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")  ' modify as needed
    ' validate YEAR on cell B1
    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
    ' Clean the table
    If LastRow >= START_ROW Then oSht.Range(START_ROW & ":" & LastRow).Clear
    ' get the first Thursday
    iDate = VBA.DateSerial(oSht.Range("B1"), 1, 1)
    iWK = 4 - VBA.Weekday(iDate, vbMonday)
    If iWK < 0 Then iWK = iWK + 7
    iDate = iDate + iWK
    ' loop through each Thursday
    Do
        iR = iR + 1
        If VBA.Month(iDate) > iMth Then
            If iMth > 0 Then
                ' populate Mth total and Qtr total
                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
            ' populate the date
            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)
    ' last total
    iR = iR + 1
    arrRes(iR, 2) = sMth & " Total"
    arrRes(iR + 1, 2) = "Q" & iMth \ 3 & " Total"
    ' write output to sheet
    Set rngTotal = MergeRng(rngTotal, oSht.Cells(START_ROW + iR - 1, 2).Resize(2))
    oSht.Cells(START_ROW, 1).Resize(iR + 1, 2).Value = arrRes
    ' apply date formatting
    oSht.Range("B" & START_ROW, oSht.Range("B" & START_ROW).End(xlDown)).NumberFormatLocal = "m/d/yyyy"
    ' apply total formatting, modify as needed
    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

' UDF to merge two ranges
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