如何在 VBA 中创建间隔 2 周的日期数组？

Question

我在这里看到了有关如何创建所有日期数组或每个月的开始日期和结束日期之间的日期的示例。但是，我正在尝试每 2 周创建一个日期数组，特别是在开始日期和结束日期之间。

例如。如果startdate = 7/18/2021 和enddate = 12/28/2025，我想要一个数组： array = {7/18/2021, 8/1/2021, 8/15/2021, ..., 12/28/2025}

我该怎么做呢？我尝试使用录制的宏，但它只使用 xlFillDefault 而实际上并没有指定使用的算法。

Sub get2weekdates()
'
' get2weekdates Macro
'

'
    ActiveCell.FormulaR1C1 = "7/18/2021"
    Range("D6").Select
    ActiveCell.FormulaR1C1 = "8/1/2021"
    Range("D5:D6").Select
    Selection.AutoFill Destination:=Range("D5:D121"), Type:=xlFillDefault
    Range("D5:D121").Select
End Sub

Answer 1

Function ArrayWithDates() 的想法是采用 2 个参数 - 第一天和大小作为可选参数（在示例中，14 表示 2 周，您可以写 21 表示 3 周或 20 表示 2周零 6 天）。

一旦得到这些，它会根据这一行的大小扩大数组 - ReDim result(size - 1)。由于数组的第 0 个元素是已知的，它被分配在循环之外 - result(0) = firstDay。

然后，在循环中，分配其他元素，每个元素都是第二天，使用DateAdd()：

Public Sub TestMe()
    
    Dim i As Long
    Dim myArray As Variant
    myArray = ArrayWithDates(#7/18/2021#)
    
    For i = LBound(myArray) To UBound(myArray)
        Debug.Print i; myArray(i)
    Next i
    
End Sub

Public Function ArrayWithDates(firstDay As Date, Optional size As Long = 14) As Variant

    Dim i As Long
    If size < 1 Then
        ArrayWithDates = Array()
        Exit Function
    End If
    
    ReDim result(size)
    result(0) = firstDay
    
    For i = 1 + LBound(result) To UBound(result)
        result(i) = DateAdd("D", 1, result(i - 1))
    Next i
    
    ArrayWithDates = result
    
End Function

结果如预期：

Answer 2

日期只是看起来像日期的双精度数。我们只需要循环并在开头添加 14 直到我们到达结束日期：

Sub get2weekdates()

    With ActiveSheet
        Dim strtdt As Double
        strtdt = .Range("C1").Value2
        
        Dim eddt As Double
        eddt = .Range("c2").Value2
        
        Dim nmDts As Long
        nmDts = (eddt - strtdt) / 14 + 1
        
        Dim otArray As Variant
        ReDim otArray(1 To nmDts, 1 To 1)
        
        Dim i As Long
        For i = 1 To nmDts
            otArray(i, 1) = strtdt + ((i - 1) * 14)
        Next i
        
        .Range("D5").Resize(nmDts, 1).Value = otArray
        .Range("D5").Resize(nmDts, 1).NumberFormat = "mm/dd/yyyy"
    End With

End Sub

---

但正如@pdtcaskey 使用 Office 365 所述，这可以是一个简单的公式：

=SEQUENCE((C2 - C1)/14 + 1,, C1, 14)