Date loop overflow-CodePudding

I have two dates, both in a named cell. Range("NewStartDate").Value = 24/07/2022 and Range("FinishDate").Value = 31/12/2023

I need all columns to have heading which is a date 7 days after previous column, i.e. A1 is NewStartDate, B1 is NewStartDate 7, C1 is NewStartDate 7*2, etc. and it will end once we reach the FinishDate.

I created this loop


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

It fills in the following column with the correct next week, however it never stops and I get an overflow error. Why is it not able to stop once we get past end date??

CodePudding user response：

I can't reproduce your error but I can recommend using arrays instead of interacting with the spreadsheet one cell at a time - it is much faster.

Your code could look like this:

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

CodePudding user response：

Create a Sequence Using a Dictionary

Since things are not all clear (to me), I've produced this little investigation.
The named ranges (cells) are named ranges of workbook scope in the workbook containing this code (ThisWorkbook).
The worksheet to be written to is the active sheet which can be a worksheet in another workbook.
It looks preferable to use a For...Next loop with Step to loop over the range of the dates.
Since the results are unique, I've pretended that I don't know how to calculate the number of the resulting dates and chose to write them to the keys of a dictionary which conveniently are already 'stored' in a 1D array (one row) for easy copying to the worksheet.

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