日期循环溢出

Question

我有两个日期，都在一个命名的单元格中。范围("NewStartDate"(。值=2022年7月24日和范围("FinishDate"(，值=2023年12月31日

我需要所有列的标题都是前一列之后7天的日期，即。A1是NewStartDate，B1是NewStartDate+7，C1是NewStartDate+7*2，等等，一旦我们到达FinishDate，它就会结束。

我创建了这个循环

Sub FillInDates()

Dim i as Integer, d as Date, x as Date

Range("NewStartDate").Value = "24/07/2022"
Range("FinishDate").Value = "31/12/2023"
d = Range("NewStartDate").Value
i = 1
Do While x < FinishDate
Range("NewStartDate").Offset(0, i).Value = DateSerial(Year(d), Month(d), Day(d) + (7*i)
x = Range("NewStartDate").Offset(0, i).Value
i = i + 1
Loop 
End Sub

它在下一周用正确的内容填充下一列，但它从未停止，我得到了一个溢出错误。为什么一旦我们超过了结束日期，它就不能停止？？

Answer 1

我无法重现您的错误，但我可以建议使用数组，而不是一次一个单元格地与电子表格交互——这要快得多。

你的代码可能是这样的：

Sub FillInDates()
Dim StartDate As Date
Dim FinishDate As Date

StartDate = Range("NewStartDate")
FinishDate = Range("FinishDate")

Dim i As Long
Dim DateArray As Variant

ReDim DateArray(1 To 1, 1 To Int((FinishDate - StartDate) / 7)) As Variant

For i = 1 To UBound(DateArray, 2)
DateArray(1, i) = StartDate + i * 7
Next i

Range("NewStartDate").Offset(0, 1).Resize(1, UBound(DateArray, 2)) = DateArray
End Sub

Answer 2

使用字典创建序列

• 由于事情(对我来说(还不完全清楚，我做了这个小调查
• 命名区域(单元格(是包含此代码(ThisWorkbook(的工作簿中工作簿作用域的命名区域
• 要写入的工作表是活动工作表，它可以是另一个工作簿中的工作表
• 看起来最好使用For。。。下一步循环步骤在日期范围内循环
• 由于结果是唯一的，我假装不知道如何计算结果日期的数量，并选择将它们写入字典的键，这些键已经方便地"存储"在1D数组(一行(中，以便轻松复制到工作表中

Option Explicit
Sub FillInDates()
' Reference the source workbook ('swb'), the workbook containing
' the named ranges (cells).
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code

' Attempt to reference the active sheet ('dsh').
Dim dsh As Object: Set dsh = ActiveSheet

' Validate the active sheet.
If dsh Is Nothing Then
MsgBox "No visible workbooks open.", vbCritical
Exit Sub
End If

' Check if the active sheet is a worksheet, the destination worksheet.
If dsh.Type <> xlWorksheet Then
MsgBox "No worksheet selected.", vbCritical
Exit Sub
End If

' If the active workbook is not the workbook containing this code,
' reference it ('dwb') and activate the workbook containing this code
' ('swb') to be able to use the workbook-scope named ranges (cells).

Dim dwb As Workbook

If Not swb Is ActiveWorkbook Then
Set dwb = ActiveWorkbook
swb.Activate
End If

' Just an example, this doesn't belong in the code.
Range("NewStartDate").Value = #12/31/2023#
Range("FinishDate").Value = #7/24/2022#

' Validate the contents of the named ranges (cells)
' and write them (the dates) to variables ('nDate','fDate')

Dim cValue As Variant

cValue = Range("NewStartDate").Value
If Not IsDate(cValue) Then
MsgBox "'" & CStr(cValue) & "' is not a date.", vbCritical
Exit Sub
End If
Dim nDate As Date: nDate = cValue
cValue = Range("FinishDate").Value
If Not IsDate(cValue) Then
MsgBox "'" & CStr(cValue) & "' is not a date.", vbCritical
Exit Sub
End If
Dim fDate As Date: fDate = cValue

If nDate > fDate Then
MsgBox "The new start date (" & CStr(nDate) _
& ") is greater than the finish date (" & CStr(fDate) & ").", _
vbCritical
Exit Sub
End If

' If it was not the workbook containing this code,
' activate the initially active workbook, the destination workbook.
If Not dwb Is Nothing Then dwb.Activate

' Write the dates to the 'keys' of a dictionary ('dict').

Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

Dim d As Date

For d = nDate To fDate Step 7
dict(d) = Empty
Next d

' Write the dates from the dictionary to the destination worksheet.

Dim cc As Long: cc = dict.Count

' Reference the destination range.
With dsh.Range("A1").Resize(, cc)
' Write the values from the 'keys' of the dictionary
' to the destination range.
.Value = dict.keys
' Format copied data.
.Font.Bold = True
.EntireColumn.AutoFit
' Clear to the right.
With .Resize(, dsh.Columns.Count - .Column - cc + 1).Offset(, cc)
.Clear
.ColumnWidth = 8.43
End With
End With
' Inform.
MsgBox "Dates filled in.", vbInformation

End Sub