VBA macro - While loop with a formula until a condition is met for every cell in a column

JkJkJake

New Member
Joined
Dec 3, 2019
Messages
2
Office Version
  1. 365
Platform
  1. Windows
I would like some help with a piece of VBA code :)

Problem: Add 'Periodicity' values (with a nested if statement) to the 'Draft date' until the date is greater than or equal to the 'Cut off date'. Repeat for all cells in a column.

Referring to the example image: In cell S28 (5/09/2019), it has applied the formula of 'P28+14' but the adjusted date (19/09/2019) is still less than the cut off date (of 25/11/2019). The macro should repeat this periodicity formula until the adjusted date reaches 28/11/2019 (5 additional iterations).

I have tried using a Do While loop where values in the 'Change baseline' loop while the value is still "Yes"... but I was not successful due to my lack of VBA experience.

Example Periodicity formula in cell S4:
=IF($G4="Weekly",P4+7,IF($G4="Fortnightly",P4+14,IF($G4="Monthly",EDATE(P4,1),IF($G4="2-Monthly",EDATE(P4,2),IF($G4="Quarterly",EDATE(P4,3),IF($G4="6-Monthly",EDATE(P4,6),"No"))))))

Example Periodicity formula in VBA:
"=IF(RC7=""Weekly"",RC[-3]+7,IF(RC7=""Fortnightly"",RC[-3]+14,IF(RC7=""Monthly"",EDATE(RC[-3],1),IF(RC7=""2-Monthly"",EDATE(RC[-3],2),IF(RC7=""Quarterly"",EDATE(RC[-3],3),IF(RC7=""6-Monthly"",EDATE(RC[-3],6),""No""))))))"

Thank you in advance for any help, please ask for any further clarification if needed!

Example image:

1575421696169.png
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Code:
Sub UpdateAdjustedDates()
    Dim CutoffDate As Date, DraftDate As Date, AdjustedDate As Date
    Dim Periodicity As String
    Dim LastRowP As Long, i As Long
    
    'Get cut-off date
    CutoffDate = Range("P1").Value
    
    'Get the last row in column P
    With ActiveSheet
        LastRowP = .Cells(.Rows.Count, "P").End(xlUp).Row
    End With
    
    For i = 4 To LastRowP
        'Get Draft date
        DraftDate = Range("P" & i).Value
        'Set Adjusted
        AdjustedDate = DraftDate
        'Get periodicity
        Periodicity = Range("Q" & i).Value
        
        Do While AdjustedDate < CutoffDate
            Select Case Periodicity
                Case "Weekly"
                    AdjustedDate = AdjustedDate + 7
                Case "Fortnightly"
                    AdjustedDate = AdjustedDate + 14
                Case "Monthly"
                    AdjustedDate = Worksheet.Function.EDate(AdjustedDate, 1)
                Case "2-Monthly"
                    AdjustedDate = Worksheet.Function.EDate(AdjustedDate, 2)
                Case "Quarterly"
                    AdjustedDate = Worksheet.Function.EDate(AdjustedDate, 3)
                Case "6-Monthly"
                    AdjustedDate = Worksheet.Function.EDate(AdjustedDate, 6)
            End Select
        Loop
        
        'Add new Adjusted date
        Range("S" & i).Formula = AdjustedDate
        
    Next

End Sub
 
Last edited:
Upvote 0
some errors with the worksheet function. Should be..

Code:
Sub GetAdjustedDates()
    Dim CutoffDate As Date, DraftDate As Date, AdjustedDate As Date
    Dim Periodicity As String
    Dim LastRowP As Long, i As Long
    
    'Get cut-off date
    CutoffDate = Range("P1").Value
    
    'Get the last row in column P
    With ActiveSheet
        LastRowP = .Cells(.Rows.Count, "P").End(xlUp).Row
    End With
    
    For i = 4 To LastRowP
        'Get Draft date
        DraftDate = Range("P" & i).Value
        'Set Adjusted
        AdjustedDate = DraftDate
        'Get periodicity
        Periodicity = Range("Q" & i).Value
        
        Do While AdjustedDate < CutoffDate
            Select Case Periodicity
                Case "Weekly"
                    AdjustedDate = AdjustedDate + 7
                Case "Fortnightly"
                    AdjustedDate = AdjustedDate + 14
                Case "Monthly"
                    AdjustedDate = CDate(Application.WorksheetFunction.EDate(AdjustedDate, 1))
                Case "2-Monthly"
                    AdjustedDate = CDate(Application.WorksheetFunction.EDate(AdjustedDate, 2))
                Case "Quarterly"
                    AdjustedDate = CDate(Application.WorksheetFunction.EDate(AdjustedDate, 3))
                Case "6-Monthly"
                    AdjustedDate = CDate(Application.WorksheetFunction.EDate(AdjustedDate, 6))
            End Select
        Loop
        
        'Add new Adjusted date
        Range("S" & i).Formula = AdjustedDate
        
    Next

End Sub
 
Upvote 0

Forum statistics

Threads
1,214,911
Messages
6,122,196
Members
449,072
Latest member
DW Draft

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top