Do Loop with Dates

[dhosi439]

I am attempting to create a do while loop to loop through the following date ranges and several into the future.

06/23/2011 to 07/7/2011
07/7/2011 to 07/21/2011
07/21/2011 to 08/4/2011
08/4/2011 to 08/18/2011

The following code runs when a command button on a sheet is clicked.

Private Sub CommandButton1_Click()

Dim intCounterDate As Integer
Dim intCounterCode As Integer
Dim intTest As Integer

intTest = 1
intCounterDate = 1
intCounterDate = 14

Do While intTest = 1
    MsgBox PayDue & " | " & PayDue + intCounterDate
    
    If intCounterDate >= 364 Then
        intTest = 0
    End If
    
    intCounterDate = intCounterDate + 14
    
    If (IsDate(ActiveCell)) Then
        ActiveCell.Font.Color = RGB(0, 0, 0)
        ActiveCell.NumberFormat = "mm/d/yyyy"
    
        If (ActiveCell >= PayDue And ActiveCell < PayDue + intCounterDate) Then
            ActiveCell.Offset(0, -2).Value = intCounterCode & "Due"
            ActiveCell.Offset(0, -2).NumberFormat = "@"
            ActiveCell.Offset(0, -2).Font.Color = RGB(0, 0, 0)
            
            intCounterCode = intCounterCode + 1
        End If
    End If

Loop

End Sub

PayDue Function

Function PayDue()
FirstPayDate = DateValue("7 Jan 2010") 'hard coded value
'FirstPayDate = ThisWorkbook.Sheets("Sheet2").Range("B2").value 'the same from a sheet
PayDue = FirstPayDate + Int((Date - FirstPayDate) / 14) * 14
End Function

The code above works correctly for the first interval, however each interval after that starts with 06/23/2011. instead of jumping to the next date interval.

So what is happening is this:

06/23/2011 to 07/7/2011
06/23/2011 to 07/21/2011
06/23/2011 to 08/4/2011
06/23/2011 to 08/18/2011

Ultimately what needs to happen is each interval needs to have a code associated with it and will input two columns to the left.

Column C = 7/1/2011
Column A = 1Due

Or

Column C = 7/8/2011
Column A = 2Due

For example:

06/23/2011 to 07/7/2011 = 1Due
07/7/2011 to 07/21/2011 = 2Due
07/21/2011 to 08/4/2011 = 3Due
08/4/2011 to 08/18/2011 = 4Due

Note: When 7/7/2011 occurs, the code would reset and 7/7/2011 would be equal to 1Due.

So the following code will need to update with each loop to show a different code (1Due, 2Due, 3Due). Also the code needs to be changed to update the date interval.

        If (ActiveCell >= PayDue And ActiveCell < PayDue + intCounterDate) Then
            ActiveCell.Offset(0, -2).Value = intCounterCode & "Due"
            ActiveCell.Offset(0, -2).NumberFormat = "@"
            ActiveCell.Offset(0, -2).Font.Color = RGB(0, 0, 0)
            
            intCounterCode = intCounterCode + 1
        End If

So what I need assistance with is changing the code above to work for multiple intervals, as the issue is with using only PayDue for the first half of the If statement. I cannot think of a way to use the initial interval of PayDue and PayDue + intCounter, then reuse Paydue + intCounter as PayDue and have the loop update the interval. Also with the update, the 1Due, would become a 2Due and so on.

For example, the current PayDue and PayDue + intCounter only updates the second half of the interval.

06/23/2011 to 07/7/2011
06/23/2011 to 07/21/2011
06/23/2011 to 08/4/2011
06/23/2011 to 08/18/2011

and the code remains 1Due because the date interval is not updating.

Any help would be great.

 

[Jerry Sullivan]

It might be simpler to multiply the number of intervals times 14 and add that to the PayDue(),
to calculate the start and finish dates of each interval.

Something like this....

Private Sub CommandButton1_Click()
    Dim dtPayDueFirst As Date, dtIntervalStart As Date
    Dim intIntervalCount As Integer, intTest As Integer
    intTest = 1
    intIntervalCount = 1
    dtPayDueFirst = PayDue()
 
    Do While intTest = 1
        dtIntervalStart = dtPayDueFirst + (14 * (intIntervalCount - 1))
        MsgBox dtIntervalStart & " | " & dtIntervalStart + 14
        If intIntervalCount >= 26 Then
            intTest = 0
        End If
        If (IsDate(ActiveCell)) Then
            If (ActiveCell >= dtIntervalStart And _
                ActiveCell < dtIntervalStart + 14) Then
                With ActiveCell
                    .Font.Color = RGB(0, 0, 0)
                    .NumberFormat = "mm/d/yyyy"
                End With
                With ActiveCell.Offset(0, -2)
                    .Value = intIntervalCount & "Due"
                    .NumberFormat = "@"
                    .Font.Color = RGB(0, 0, 0)
                End With
                intTest = 0
            End If
        End If
        intIntervalCount = intIntervalCount + 1
    Loop
End Sub

I've modified the function to stop as soon as the matching interval is found. You can adjust that if that isn't your intent.

I'm not sure if a Do While Loop is the best fit for this purpose
(unless you just want to learn more about using Do Loops in VBA).

If you just want to be able to take a date in Column C and return its PayDue interval dates and count,
each of those can be found with a single calculation similar to your PayDue Function.

Hope this helps!

 

[dhosi439]

Thank you so much, your code worked perfectly. I made a few adjustments to fit my needs, but over all it was exactly what I was looking for.

Private Sub cmdUpdate_Click()
    Dim dtPayDueFirst As Date, dtIntervalStart As Date
    Dim intIntervalCount As Integer, intTest As Integer
    intTest = 1
    intIntervalCount = 1
    dtPayDueFirst = PayDue()
 
    Do While intTest = 1
        dtIntervalStart = dtPayDueFirst + (14 * (intIntervalCount - 1))
        'MsgBox dtIntervalStart & " | " & dtIntervalStart + 14
        If intIntervalCount >= 26 Then
            If (IsDate(ActiveCell)) Then
                With ActiveCell.Offset(0, -2)
                    .Value = "FDue"
                    .NumberFormat = "@"
                    .Font.Color = RGB(0, 0, 0)
                End With
            End If
            intTest = 0
        End If
        If (IsDate(ActiveCell)) Then
            If (ActiveCell >= dtIntervalStart And _
                ActiveCell < dtIntervalStart + 14) Then
                With ActiveCell
                    .Font.Color = RGB(0, 0, 0)
                    .NumberFormat = "mm/dd/yyyy"
                End With
                    If (ActiveCell < PayDue Or ActiveCell.Offset(0, -2) = "Paid" Or ActiveCell.Offset(0, -2) = "RDue") Then
                        With ActiveCell.Offset(0, -2)
                            .NumberFormat = "@"
                            .Font.Color = RGB(0, 0, 0)
                        End With
                    Else
                        With ActiveCell.Offset(0, -2)
                            .Value = intIntervalCount & "Due"
                            .NumberFormat = "@"
                            .Font.Color = RGB(0, 0, 0)
                        End With
                    End If
                intTest = 0
            End If
        End If
        intIntervalCount = intIntervalCount + 1
    Loop
End Sub