Excel VBA Date Generation Loop

Question

I have a sheet i am working on that i need to populate all the days between 2 dates for a month 54 times.

I have got together a loop that can do this for the first section - I now need ti replicated 54 times.

I have figured out a loop to copy and paste this range the 54 times which works as it should. however I am wondering whether there is a way to put the date generation loop inside the duplication loop and generate every date rather than copy and paste?

I am mainly looking for the most efficient method as this will potentially be scaled up in future so any pointers with my code would be greatly appreciated.

Sub WriteDatesLoopTest()

'Disables Screen Flickering on Copy/Paste
Application.ScreenUpdating = False
OffsetValue = 42
'----------------------------------------------
    Dim StartDate       As Range
    Dim EndDate         As Range
    Dim OutputRange     As Range
    Dim ClearRange      As Range
    Dim StartValue      As Variant
    Dim EndValue        As Variant
    Dim DateRangeCopy   As Range
    Dim EmployeeCount   As Range
    Dim MonthValue      As Range
'----------------------------------------------
    Set ClearRange = Range("A9:A39")
    Set StartDate = Range("T4")
    Set EndDate = Range("T5")
    Set OutputRange = Range("A9")
    Set DateRangeCopy = Range("A9:A39")
    Set EmployeeCount = Range("O1")
    Set MonthValue = Range("J1")
    StartValue = StartDate
    EndValue = EndDate

'----------Date Generation Loop----------------

    If EndValue - StartValue <= 0 Then
        Exit Sub
        End If
        ColIndex = 0
            For i = StartValue To EndValue
                OutputRange.Offset(ColIndex, 0) = i
                ColIndex = ColIndex + 1
            Next

'----------Copy & Paste------------------------
n = EmployeeCount
For j = 0 To (n - 1)
    'ClearRange.Offset(OffsetValue * j, 0).ClearContents
    DateRangeCopy.Copy
    With DateRangeCopy.Offset(OffsetValue * j, 0)
      .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
       SkipBlanks = False
    End With

    'Show Status Bar in Bottom Left
    Application.StatusBar = "Progress: " & Format(j / n, "0%")

   Next

'Display Message on completion
MsgBox "Dates Generated"
'Removes 'Walking Ants' From copied selection
Application.CutCopyMode = False
'Enables Screen Flickering on Copy/Paste
Application.ScreenUpdating = True
'Reset Status Bar in Bottom Left
Application.StatusBar = False
'-----------------------------------

    End Sub

Thank you

Answer 1

Just seen the comments. Yes Code Review would be good. You probably want to move the entire process into an array.

This demonstrates all the required elements.

Option Explicit
Public Sub GenerateDates()
    Const LOOPCOUNT As Long = 54
    Dim i As Long, j As Long
    Dim startDate As Long, endDate As Long, rowCounter As Long
    startDate = CLng(Now)
    endDate = startDate + 7
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = 1 To LOOPCOUNT
            For j = startDate To endDate
                rowCounter = rowCounter + 1
                .Cells(rowCounter, 1) = j
            Next j
             rowCounter = rowCounter + 5 '<== Add gap
        Next i
        .Columns("A").NumberFormat = "m/d/yyyy"
    End With
    Application.ScreenUpdating = True
End Sub

Doing the same thing in memory (I have included a second dimension as you may have additional columns in your data. My principle was really about showing the dates increment with row gap.)

Option Explicit
Public Sub GenerateDates() '697
    Const LOOPCOUNT As Long = 54      
    Dim i As Long, j As Long
    Dim startDate As Long, endDate As Long, rowCounter As Long
    startDate = CLng(Now)
    endDate = startDate + 7
    Dim ROWGAP As Long: ROWGAP = 41-(Enddate-StartDate)
    Dim outputArr()
    ReDim outputArr(1 To (((endDate - startDate + 1) + ROWGAP) * LOOPCOUNT) - ROWGAP, 1 To 1)
    Application.ScreenUpdating = False
    With ActiveSheet
        For i = 1 To LOOPCOUNT
            For j = startDate To endDate
                rowCounter = rowCounter + 1
                outputArr(rowCounter, 1) = j
            Next j
            rowCounter = rowCounter + ROWGAP '<== Add gap
        Next i
        .Cells(1, 1).Resize(UBound(outputArr), UBound(outputArr, 2)) = outputArr 'This is only with one dimensional
        .Columns("A").NumberFormat = "m/d/yyyy"
    End With
    Application.ScreenUpdating = True
End Sub

---

tl;dr;

The principle is basically that you want an outer loop that increments from 1 to 54. Then an inner loop that increments from start date to end date. I treat date as a Long and simply add one to the startDate until I reach the endDate in the inner loop. For i = 1 To LOOPCOUNT is doing the repeat work... here you could be using your copy paste. I increment the rowCounter variable by 5 before the next repeat to leave some blank rows between repeats.

The first version writes to the sheet for every row with .Cells(rowCounter, 1) = j . That is an expensive operation "touching" the sheet each time. The second version does the same process but doesn't write to the sheet until the very end. Instead, it writes to an array. This is much faster as is all done in memory (no going to disk).

I know how many rows I will have in the array because I know how many times I am repeating the entire process (54), the number of days from startDate and endDate (8) and the number of padding rows I am adding (5). So I can size my array to write to with ReDim outputArr(1 To (((endDate - startDate + 1) + ROWGAP) * LOOPCOUNT) - ROWGAP, 1 To 1) . I don't need 5 rows padding on the 54th loop so I remove these from the total row count.

---

For understanding working with arrays and data in the worksheet the article VBA Arrays And Worksheet Ranges is worth a read, a long with the more general VBA Arrays

Answer 2

The fewer tasks that a subroutine performs, the easier it is to write, test, and modify. For this reason I created a function to generate the output Array.

OffsetValue has a somewhat ambiguous name. I used SectionLength instead.

Sub AddDates()
    Const OffsetValue = 42
    Dim data() As Variant
    data = getDatesArray(#6/1/2018#, #6/30/2018#)
    With Worksheets("Sheet1")
        .Columns(1).ClearContents
        .Range("A1").Resize(UBound(data)).Value = data
    End With
End Sub

Function getDatesArray(StartDate As Date, EndDate As Date, Optional SectionLength As Long = 42, Optional RepeatCount As Long = 54) As Variant()
    Dim results() As Variant
    Dim count As Long, n As Long
    ReDim results(1 To SectionLength * RepeatCount, 1 To 1)

    If EndDate >= StartDate Then
        Do
            count = count + 1
            For n = 0 To UBound(results) - SectionLength Step SectionLength
                results(n + count, 1) = StartDate
            Next
            StartDate = StartDate + 1
        Loop Until StartDate = EndDate
    End If
    getDatesArray = results
End Function