Hello! My objective with this project was originally to create a program that generates recurring due dates for physical exams.
When a client is entered into the system for the first time the code looks at their admission date and generates a list of dates that the person will be due for a physical.
Originally the frequency for physical exams was 30 days from the date of admission and every 180 days until their discharge date or until todays date.
Every time the user selects a patient on the user form, the code runs and will add any new dates to the schedule that are required based on the 180 day frequency and todays date. This code worked fine.
Now, I have been told that the frequency for appointments is no longer every 180 days for all children, now it is based on the child’s age at admission.
The children now need to have a physical exam at the following ages:
5 days old
Every month from age 1 month old to age 6 months old
Every 3 months from age 6 months old to age 18 months old
Every 6 months from age 18 months old to age 84 months old (7 years old)
Every 12 months from age 7 to 21
Below , I have shared my original code that worked fine with the initial 30 day frequency and then 180 day frequency following the initial.
I am also sharing a new function I wrote that will get the First Due Date based on the Childs age at Admission but this is where I am having trouble:
[SIZE=20px]How and where can I insert this function (or an adapted version of the function) into the original code to account for the child's age and the correct frequency each time the loop occurs to add the right due date to the schedule?[/SIZE]
[SIZE=14px]This is my Original Code that does the job of the original objective[/SIZE][SIZE=14px][/SIZE]
Code
Sub GenerateRecurringAppointments()
Dim name As String, firstAssessName As String, recurringAssessName As String
Dim frequency As Integer, firstFrequency As Integer
Dim FirstDate As Date, LastDate As Date, NextDate As Date, AdmissionDate As Date, FirstDue As Date, DOB As Date
Dim rng As Range, daterange As Range
Dim Discharged As Boolean
firstAssessName = "PHYSICAL: INITIAL"
recurringAssessName = "PHYSICAL"
firstFrequency = 30
frequency = 180
name = "ZZZ, Topper" 'FOR TESTING PURPOSES, IS ACTUALLY USERFORM2.COMBOBOXX2.TEXT
AdmissionDate = "6/27/2017" 'FOR TESTING PURPOSES, IS ACTUALLY USERFORM2.TEXTBOXX9.VALUE
FirstDue = AdmissionDate + firstFrequency
Discharged = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
PROCESS:
With PHYSICAL1
.Activate
'CLEAR FILTERS, SORT, THEN FILTER BY NAME
Call ClearTableFilter("Table11", PHYSICAL1)
Call SortTable(PHYSICAL1, "Table11", "A2", "H2")
Call SortTable(PHYSICAL1, "Table11", "I2")
.ListObjects("Table11").Range.AutoFilter Field:=1, Criteria1:=name
'IF NAME DOES NOT EXIST GO TO NORANGE FOUND
On Error GoTo NoRangeFound
Set rng = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Find(What:=name, LookAt:=xlWhole)
'IF NAME ALREADY EXISTS GO TO THE FIRST RECORD OF THAT NAME
If Not rng Is Nothing Then
Set rng = .Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Find(What:=firstAssessName, LookAt:=xlWhole)
Application.GoTo rng
End If
ACrow = ActiveCell.Row
'DETERMINE IF DISCHARGE IS N/A OR DATE
If .Cells(ACrow, 4).Value = "N/A" Then
LastDate = Date
Discharged = False
Else
LastDate = .Cells(ACrow, 4).Value
Discharged = True
End If
'FIRST DATE IS THE DUE DATE IN THAT ROW
FirstDate = .Cells(ACrow, 8).Value
'IN CASE ADMISSION DATE WAS CHANGED MAKE SURE FIRST DUE DATE IS ADMISSION DATE + 180
If FirstDate <> AdmissionDate + firstFrequency Then
.Cells(ACrow, 8).Value = AdmissionDate + firstFrequency
FirstDate = .Cells(ACrow, 8).Value
End If
NextDate = FirstDate
'CHECK DATES UNTIL NEXTDATE IS AFTER DISCHARGE DATE/TODAY
Do Until NextDate >= LastDate
NextDate = NextDate + frequency
'LOOK IN THE VISIBLE DUE DATES
Set daterange = .Range("H2:H" & .Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible). _
Find(What:=NextDate, LookAt:=xlWhole)
'IF NEXT DUE DATE IS NOT ON SHEET INSERT ROW, _
INSERT NAME, RECURRINGASSESS NAME ,NEXT DATE
If daterange Is Nothing Then
If NextDate > LastDate And Discharged = True Then Exit Do
ActiveCell.EntireRow.Insert
Application.Calculation = xlCalculationAutomatic
.Cells(ACrow, 1).Value = name
.Cells(ACrow, 5).Value = recurringAssessName
.Cells(ACrow, 8).Value = NextDate
Application.Calculation = xlCalculationManual
End If
Loop
'SORT TABLE
Call SortTable(PHYSICAL1, "Table11", "A2", "H2")
Call SortTable(PHYSICAL1, "Table11", "I2")
On Error GoTo 0
End With
Discharged = False
Exit Sub
NoRangeFound: 'IF NAME DOES NOT EXIST YET
'CLEAR THE TABLE FILTER AND GO TO FIRST EMPTY ROW
Call ClearTableFilter("Table11", PHYSICAL1)
Call GoToFirstEmptyRow(PHYSICAL1)
Application.Calculation = xlCalculationAutomatic
'PUT NAME IN COL 1 , FIRSTASSESSNAME IN COL 5, FIRSTDUE IN COL 8
PHYSICAL1.Cells(ActiveCell.Row, 1).Value = name
PHYSICAL1.Cells(ActiveCell.Row, 5).Value = firstAssessName
PHYSICAL1.Cells(ActiveCell.Row, 8).Value = FirstDue
Application.Calculation = xlCalculationManual
Resume PROCESS
End Sub[SIZE=14px]This is the function I wrote [/SIZE][SIZE=14px]to figure out what the first due date should be for the schedule based on the age of the child in months or days[/SIZE]
Code
Function FirstDueDate() As Date[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000]Dim AdmissionDate As Date, DOB As Date, FirstDateAfterAdmission As Date, FirstDue As Date[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000]Dim DaysOld As Boolean[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000]DaysOld = False[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] With PHYSICAL1[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] ACrow = ActiveCell.Row[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] AdmissionDate = CDate(.Cells(ACrow, 3).Value)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] DOB = CDate(.Cells(ACrow, 11).Value)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] AdmissionAge = date_diff_to_months(DOB, AdmissionDate)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDateAfterAdmission = DateAdd("d", 30, AdmissionDate) 'initial physical needs to occur within 30days of Admission[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] 'FIGURE OUT WHAT FIRST DUE DATE SHOULD BE BASED ON AGE[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Select Case AdmissionAge[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is < 1 'IF CHILD IS LESS THAN A MONTH OLD AT ADMISSION[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] DaysOld = True[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] AdmissionAge = DateDiff("d", DOB, AdmissionDate)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] If AdmissionAge <= 5 Then 'CHILD IS 5 DAYS OLD OR YOUNGER[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Debug.Print "Schedule starts at 5 days Old"[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Select Case AdmissionAge[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case 1[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = DateAdd("d", 4, DOB)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case 2[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = DateAdd("d", 3, DOB)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case 3[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = DateAdd("d", 2, DOB)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case 4[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = DateAdd("d", 1, DOB)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case 5[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = DOB[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] End Select[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Else 'CHILD IS BETWEEN 6 DAYS OLD AND 30 DAYS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Debug.Print "Schedule starts at 1 Month old"[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 1)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] End If[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case 1 To 6 'CHILD IS BETWEEN 1 AND 6 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, AdmissionAge)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 9 'CHILD IS BETWEEN 6 AND 9 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 9)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 12 'CHILD IS BETWEEN 9 AND 12 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 12)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 15 'CHILD IS BETWEEN 12 AND 15 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 15)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 18 'CHILD IS BETWEEN 15 AND 18 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 18)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 24 'CHILD IS BETWEEN 18 AND 24 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 24)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 30 'CHILD IS BETWEEN 24 AND 30 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 30)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 36 'CHILD IS BETWEEN 30 AND 36 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 36)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 42 'CHILD IS BETWEEN 36 AND 42 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 42)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 48 'CHILD IS BETWEEN 42 AND 48 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 48)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 54 'CHILD IS BETWEEN 48 AND 54 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 54)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 60 'CHILD IS BETWEEN 54 AND 60 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 60)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 66 'CHILD IS BETWEEN 60 AND 66 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 66)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 72 'CHILD IS BETWEEN 66 AND 72 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 72)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 78 'CHILD IS BETWEEN 72 AND 78 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 78)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is <= 84 'CHILD IS BETWEEN 78 AND 84 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = WorksheetFunction.EDate(DOB, 84)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Case Is > 84 'CHILD IS MORE THAN 84 MONTHS OLD[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] FirstDue = DateAdd("d", 30, AdmissionDate)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] End Select[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] [/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] End With[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] If DaysOld = True Then Debug.Print AdmissionAge & " Days Old at Admission" Else: Debug.Print AdmissionAge & " Months Old at Admission"[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Debug.Print FirstDue & " FirstDue"[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Debug.Print FirstDateAfterAdmission & " FirstDateAfterAdmission"[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] If FirstDateAfterAdmission < FirstDue Then FirstDueDate = FirstDateAfterAdmission Else: FirstDueDate = FirstDue[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Debug.Print FirstDueDate & " FirstDueDate"[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] currentAge = date_diff_to_months(DOB, FirstDueDate)[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000] Debug.Print currentAge & " Months Old at time of Due Date"[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000]End Function[/COLOR][/SIZE][/FONT][FONT=Calibri][size=12][COLOR=#000000][B][/B][/COLOR][/SIZE][/FONT]