Posts by AKAUFMAN1

AKAUFMAN1 · Aug 28th 2018

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

Display More

[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]

AKAUFMAN1 · Jun 5th 2018

This is an example of a piece of my userform code that is used many many times in the application referencing different listboxes, list columns, and sheet ranges each time. I have been trying to create a sub procedure with parameteres to use instead , but i keep getting stuck when trying to reference the sheet range.

Code

r = UserForm2.ListBoxAppointments.ListIndex
RecordNumber = UserForm2.ListBoxAppointments.List(r, 20)
    
    With APPOINTMENTS1
        .Activate
        Set filteredRng = .Range("U2:U" & .Cells(Rows.Count, "A").End(xlUp).row). _
        SpecialCells(xlCellTypeVisible).Find(What:=RecordNumber, LookAt:=xlWhole)
            If Not filteredRng Is Nothing Then
            Application.Goto filteredRng
            End If
    End With

Display More

This is the sub i tried to create:

Code

Public Sub PassARange(lbName As MSForms.ListBox, lbListCol As Integer, filteredRng As Range)
r = lbName.ListIndex
RecordNumber = lbName.List(r, lbListCol)
    
    With APPOINTMENTS1
        Set filteredRng = filteredRng.Find(What:=RecordNumber, LookAt:=xlWhole)
            If Not filteredRng Is Nothing Then Application.Goto filteredRng
    End With
                
End Sub

And this is how i tried to call it....

Code

Call PassARange(UserForm2.ListBoxAppointments, 20, .Range("U2:U" & .Cells(Rows.Count, "A").End(xlUp).row). _
        SpecialCells(xlCellTypeVisible))

Can someone please help me figure out how i am supposed to reference the range? Each time i use this piece of code i need to reference an entire column of only visible cells, as this usually comes after code to filter the sheet. The columns also need to always reference the last row, as data is continuously added.

Thank you !

AKAUFMAN1 · May 7th 2018

Hello! When a user selects an item from the multicolumn Listbox ( ListBoxNonRoutine) in UserForm2 and then clicks the UpdateButton, UserFormNonRoutine is opened. Then the user can update the control values in UserFormNonRoutine and clicks Save to update the control values on UserFormNonRoutine and update the worksheet cell values. After the cells are updated, ListBoxNonRoutine from the original UserForm2 multicolumn Listbox is refreshed to reflect the changes as well. This all works....but what i am having trouble doing is having the code automatically select the original item that was selected and updated in ListBoxNonRoutine. The only way i have been able to refresh the listbox is by clearing it first but when i clear it, it deselects the item. Here is the code:

Code

Private Sub SaveButton_Click()
   '******save the control values to the activecell.row
   With NONROUTINE
        ACrow = ActiveCell.Row
        For A = 1 To 13
        On Error Resume Next
        Select Case A
            Case 1 To 3 ' TextBoxes
                Cells(ACrow, A).Value = Me("TextBox" & A).Value
            Case 5, 6, 8, 12, 13 ' TextBoxes
                Cells(ACrow, A).Value = Me("TextBox" & A).Value
                    If IsDate(TextBox8.Value) Then
                        UserForm2.RiskBenefitCheckBox = True
                    ElseIf Not IsDate(TextBox8.Value) Then
                        UserForm2.RiskBenefitCheckBox = False
                    End If
            Case 10
                If CheckBox10.Value = True Then 'checkbox
                    Cells(ACrow, 10).Value = True
                    UserForm2.NRfollowUpCheckBox = True
                ElseIf CheckBox10.Value = False Then
                    Cells(ACrow, 10).Value = False
                    UserForm2.NRfollowUpCheckBox = False
                End If
            Case 11 ' ComboBoxes
                Cells(ACrow, A).Value = Me("ComboBox" & A).Value
            End Select
        Next A
                If OptionButton4In.Value = True Then 'option buttons
                    Cells(ACrow, 4).Value = "Inpatient"
                ElseIf OptionButton4Out.Value = True Then
                    Cells(ACrow, 4).Value = "Outpatient"
                Else
                    Cells(ACrow, 4).Value = vbNullString
                End If
    End With
   SaveButton.Visible = False
                For Each c In UserFormNonRoutine.Controls 'clear all boxes
                    If TypeOf c Is MSForms.TextBox Or TypeOf c Is MSForms.ComboBox Then
                        c.Value = vbNullString
                        c.BackColor = RGB(255, 255, 255)
                    ElseIf TypeOf c Is MSForms.CheckBox Or TypeOf c Is MSForms.OptionButton Then
                        c.Value = False
                    End If
                Next c


'***REFRESH LISTBOX
Dim originalindex As Variant
originalindex = UserForm2.ListBoxNonRoutine.Value
            UserForm2.ListBoxNonRoutine.Clear
            Dim NewProcedureRange As Range, Name As String
            Dim rng As Range, AdmissionDate As Date
            Set rng = NONROUTINE.Range("A:A").Find(What:=UserForm2.ComboBoxx2.Value, LookAt:=xlWhole) 'find name in non routine sheet
                If Not rng Is Nothing Then 'if the name is found in column A
                    On Error Resume Next
                    NONROUTINE.ListObjects("Table21").Range.AutoFilter Field:=1, Criteria1:=UserForm2.ComboBoxx2.Value 'filter table to all records for that name
                    Set NewProcedureRange = NONROUTINE.Range("A2:M" & NONROUTINE.Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible) 'new range to reference filtered range
                    UserForm2.ListBoxNonRoutine.List = NewProcedureRange.Value ' display filtered range for that person name in listbox
                        With UserForm2.ListBoxNonRoutine
                            .ColumnCount = 13
                            .ColumnWidths = "0 pt;0 pt;110 pt;55 pt;55 pt;55 pt;0 pt;0 pt;0 pt;0 pt;0 pt;0 pt;0 pt"
                        End With
                End If
UserForm2.ListBoxNonRoutine.SetFocus
UserForm2.ListBoxNonRoutine.Selected(originalindex) = True


   MsgBox "Record Successfully Updated!", vbExclamation
End Sub

Display More

AKAUFMAN1 · Apr 16th 2018

I have a worksheet selection change event that sets the values in column A as such:

Code

Sheets("Investigation Grid").Range("A2").Value = 1
LastRow2 = Range("B" & Rows.Count).End(xlUp).Row
Sheets("Investigation Grid").Range("A3:A" & LastRow2).FormulaR1C1 = "=IF(RC[7]=R[-1]C[7],R[-1]C,R[-1]C+1)"

So if the value in column H matches the value in column H for the row above it, then the index number in column A is the same as the index number in column A in the row above, if the value in column H does not match the value in column H in the row above, then the index number in column A is +1 of the index number in row above it.
This is a way for me to group rows that belong to the same case number found in column H.

I am trying to add to my worksheet selection change event to look at each index number as its own range… then look at the values in column 22 of that index number range.
For instance, there are 4 rows that have index number 78.
Within those 4 rows, I want to look at column 22 and if any of the values in the 4 rows in column 22 say “Substantiated” or “Indicated” then all 4 rows in column 41 should return “Substantiated” or “Indicated” based on whichever value is found in column 22. If none of the column 22 values are “Substantiated” or “Indicated” then the values in Column 41 should be the same as the values in column 22.

I have updated this to include code i started working on. The ElseIf section is where i need assistance! Thank you !

Code

Sub DeterminationType()
On Error GoTo errHandler
Dim lastRow As Long, k As Long, t As Long, xRange As Range


lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set xRange = Range("A1:A" & lastRow)
    For t = 1 To lastRow
        k = Application.WorksheetFunction.CountIf(xRange, Cells(t, 1))
        t = t + k - 1
            If k = 1 Then    ' if index number only exists 1 time
                Cells(t, 41).Value = Cells(t, 22).Value  ' then put the value from column 22 in column 41
            ElseIf k > 1 Then   ' if index number exists more than 1 time
    [COLOR=#FF0000]             ' need to loop through the values in column 22 and evaluate if any of the k values are "Substantiated" or "Indicated" then _
                 cells in column 41 need to be "Substantiated" or "Indicated" based on whichever of the two values are present _
                 If "Substantiated" or "Indicated" is not found in the k values then cells in column 41 should = values in column 22[/COLOR]
            End If
    Next t
    Exit Sub
errHandler:
 MsgBox "Error " & Err.Number & " - " & Err.Description
 
 End Sub

Display More

AKAUFMAN1 · Apr 6th 2018

Quote from KjBox

It is not possible to change a control's Name or Tag at run time.

I will have time over the weekend to look into using the variable column number method further, and get the ListBox1_Click procedure working.

Thank you KjBox! I'm sorry I am just seeing your response. I have been on vacation the past week! If you are able to find a solution, please let me know! It would be incredibly helpful!!

AKAUFMAN1 · Mar 30th 2018

Quote from rabsofty

I thought of a way (kinda)
You could put the column#'s in the objects tag field (label names would not change or you can give them a name)
eg:
labelx21 tag = 22 (col#)
combobox21 tag = 22
textbox21 = 22

Then when you add a column, you can run a piece of code to change all tags.

Display More

I cant figure out a way to actually loop through the controls and add or update the tag property at run time either.

AKAUFMAN1 · Mar 30th 2018

Thank you both for the responses.
KjBox : I hear what you are saying, so if i used that logic of re-naming the controls ( or even putting the column header name in the tag property of each control ) i'm not sure how i would then modify my code that uses the other naming convention i was using by putting column number in the name. For example: part of my listbox click code,

Code

For listCol = 1 To 46 
                Select Case listCol
                    Case 1, 2, 3, 13, 14 
                        Controls("ComboBoxx" & listCol + 1) = ListBox1.Column(listCol)
                    Case 6, 7, 8, 9, 10, 11, 17, 18, 20, 23, 25, 27, 29, 32, 34, 36, 39, 41, 43, 45, 46 
                        Controls("TextBoxx" & listCol + 1) = ListBox1.Column(listCol)
                    Case 4 'STATUS 
                        If ListBox1.Column(listCol) = "Active" Then
                            OptionButton1.Value = True
                        ElseIf ListBox1.Column(listCol) = "Discharged" Then
                            OptionButton2.Value = True
                        End If
                    Case 5 'GENDER' #
                        If ListBox1.Column(listCol) = "Female" Then
                            OptionButton3.Value = True
                        ElseIf ListBox1.Column(listCol) = "Male" Then
                            OptionButton4.Value = True
                        ElseIf ListBox1.Column(listCol) = "Transgender" Then
                            OptionButton5.Value = True
                        End If
End Select
            Next listCol

Display More

So i am having trouble figuring out how i would modify code like this to use the new naming convention?

In regards to your question about the text boxes and combo boxes being disabled. The boxes are enabled until the user clicks the listbox or clicks search. They are then disabled until the user clicks update record button.

AKAUFMAN1 · Mar 30th 2018

If you reference column numbers in the tag property and then later on you need to insert a new column right in the middle of the spreadsheet (let’s say column 15) ..., all of the current tags from 15 on will need to increase by 1 ... is there a way to loop through all the tags and update them without having to manually adjust all of the tags in the property window ?

AKAUFMAN1 · Mar 28th 2018

I know...neither can i ! So there is basically no way to modify control names at all unless you manually do it? I wouldn't mind if it was just adjusting the code by increasing the numbers manually but it also requires going into the properties of each control and changing those as well...and as you can see there are about 50 of them on page 1 of the multipage alone.

AKAUFMAN1 · Mar 28th 2018

Yes, but not just the label#..any of the control name #'s to always reflect the column#... This is more straight forward example using the first part of my ListBox1_click event which references just the combobox and textbox controls being filled when the list box is selected:

Code

Private Sub ListBox1_Click() 
'***************************IF LISTBOX HAS BEEN SELECTED*******************************************
    If ListBox1.ListIndex >= 0 Then
        With Me
            SearchButton.Enabled = False
            DeleteRecordButton.Enabled = True
            AddUpdateButton.Enabled = True
            '**********FILL BOXES WITH LIST ITEMS*******************************
            On Error Resume Next
            For listCol = 1 To 46 
                Select Case listCol
                    Case 1, 2, 3, 13, 14
                        Controls("ComboBoxx" & listCol + 1) = ListBox1.Column(listCol)
                    Case 6, 7, 8, 9, 10, 11, 17, 18, 20, 23, 25, 27, 29, 32, 34, 36, 39, 41, 43, 45, 46
                        Controls("TextBoxx" & listCol + 1) = ListBox1.Column(listCol)
                 End Select
            Next listCol
        End With

Display More

ListBox1 is populated using :

Code

LastRow = Tracking.Cells(Rows.Count, "A").End(xlUp).Row   
    Set myTable = Tracking.Range("A6:AU" & LastRow) 
    ListBox1.List = myTable.Value

So the code is filling the boxes based on the ListBox Column Numbers which are associated with the columns on my Tracking.sheet ...therefore if i were to insert a new column anywhere in Tracking sheet other than at the very end, it would throw off all of the control name references.

AKAUFMAN1 · Mar 27th 2018

The weird thing is, there were under 10 rows... so i have no idea why it was taking so long.
What i decided to do instead was replace the part of the code for filtering the table by comboboxx2.value with a subroutine i created for copying the applicable values into a temp sheet like this....

Code

DEtemp.Cells.ClearContents 'clear everything from DEtemp that may have been there before
Dim LastRow As Long, c As Range, Name As String
    Name = UserForm2.ComboBoxx2.value
    With DEsheet
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        Set MyRange = DEsheet.Range("A2:A" & LastRow)
    End With
    With MyRange
        For Each c In MyRange 'for each cell in column 1
                   If c.value = Name Then
                        c.Copy Destination:=DEtemp.Range("A" & DEtemp.Range("A" & DEtemp.Rows.Count).End(xlUp).Row + 1)
                        c.Offset(0, 2).Copy Destination:=DEtemp.Range("B" & DEtemp.Range("B" & DEtemp.Rows.Count).End(xlUp).Row + 1)
                        c.Offset(0, 3).Copy Destination:=DEtemp.Range("C" & DEtemp.Range("C" & DEtemp.Rows.Count).End(xlUp).Row + 1)
                        Application.CutCopyMode = False
                    End If
        Next c
    End With

Display More

Then proceeding with the loop for referencing the labels.
That seemed to speed it up CONSIDERABLY!

AKAUFMAN1 · Mar 27th 2018

I have attached the workbook. AllTracking1 is the sheet for which the UserForm2 controls reference the column numbers. . . So ComboBoxx2 represents Column 2 of AllTracking1.
On Page 1 of UserForm2. MultiPage Form their are many more controls which reference the columns such as... Labelx21 , TextBoxx21, CheckBoxx21, CheckBox21, ComboBox21, ComboBoxNo21 all reference column 21 of AllTracking1 sheet. I am just trying to find a fast way to update all of these control names so if i need to add a column after the column which is currently 20 (or T) , i can update all of the controls that originally had 21 in their name to now have 22 in their name.

AKAUFMAN1 · Mar 27th 2018

Hello! I have a lot of controls on a UserForm that are named in association with the column number they represent. For instance: TextBox1, TextBox2, TextBox3, etc. up to the 50's. Their are not only TextBoxes but also Labels and CheckBoxes that follow the same naming convention. All of my code relies on this naming convention when referencing the controls.
The other day i had a request for a new column A to be added to the sheet, resulting in me having to manually change the name property of every single control to be + 1 of what it currently was set at. My question is, if a column needs to be added anywhere on the sheet in-between current columns, how can i change all of the control names without manually going in and updating the properties (which takes a VERY long time). I tried creating a loop like this, but it doesn't work. The debug error i get is Run-time error 382: Could not set the name property. Can no set property at runtime.

Code

Sub NameChange()
Dim ctrl As MSForms.control


For Each ctrl In UserForm2.MultiPage1.Pages(1).ConsentsFrame2.Controls
    If ctrl.Name Like "Labelx*" Then
        For A = 20 To 43
            Select Case A
                Case 20, 23, 25, 27, 29, 32, 34, 36, 39, 41, 43
                  ctrl.Name = "Labelx" & A
                  A = A + 1
            End Select
            Next
        End If
    Next
    
End Sub

Display More

AKAUFMAN1 · Mar 26th 2018

Thank you for your response Ger! I greatly appreciate it!
1. I updated the code to reflect your suggestion with removing the Activate and Select statements and replaced with the reference to the range. That was exactly what i was looking for.
2. I took out the Application.EnableEvents... I did not know that it was not applicable to userform controls so thank you!
3. Instead of having a ton of change event codes for each checkbox and combobox involved in this event (there will end up being about 40 of each control), is it possible for me to create a Class Module with a change event to include the whole group of controls involved based on when ComboBoxx2 changes to a new name? I have a few Class Modules already in action but i'm just not sure how i would include the current code in a class module to satisfy the objective.
4. My listbox is not linked via .rowsource. It is set up like this:

Code

Set mySheet = ThisWorkbook.Sheets("All.Tracking1") 
LastRow = mySheet.Cells(Rows.Count, "A").End(xlUp).Row
Set myTable = mySheet.Range("A6:AS" & LastRow)
ListBox1.List = myTable.value

After updating my code to reflect the changes you suggested in Number 1 , the code is still running VERY slow... I think i narrowed it down to the reason being this part of the code...

Code

DEsheet.ListObjects("Table6").Range.AutoFilter Field:=1, Criteria1:=UserForm2.ComboBoxx2.value

So instead of filtering the table to find ComboBoxx2.value and then search for the Labelx values within the filtered range... I tried to use a Find/Find Next method.
I created a separate module outside of the userform and testing it by just finding a name and looping through to provide the column 4 value of each instance of the name found.
This was successful.

Code

Sub TestOnSheet()
Dim Name As String, FoundName As Range, FirstNameAddr As String, LastCell As Range, i As Long
    With DEsheet.Columns(1)
    Name = DEsheet.Range("A2").value ' first name in row 2 , just for testing , will become UserForm2.ComboBoxx2.Value
    i = 2
        Set LastCell = .Cells(.Cells.Count)
        Set FoundName = .Find(What:=Name, LookAt:=xlWhole, after:=LastCell)
        If Not FoundName Is Nothing Then
            FirstNameAddr = FoundName.Address
            Do
                Debug.Print DEsheet.Cells(i, 4).value ' print the values in column 4
                i = i + 1
                Set FoundName = .FindNext(FoundName)
            Loop While Not FoundName Is Nothing And FirstNameAddr <> FoundName.Address
        End If
    End With
End Sub

Display More

However, when i added it to the userform module and added in the For Each and For loops in between Do and Loop, along with all the UserForm references, i got Run-time Error 91: Object Variable or With Block Variable Not Set.

This is the new full code that i cant get to work, i extracted it from ListBox1_Click Event and made it its own button for testing:

Code

Private Sub TestButton_Click()
Dim Name As String, FoundName As Range, FirstNameAddr As String, LastCell As Range
Dim Label As String, FoundLabel As Range
 
Name = UserForm2.ComboBoxx2.value
    With DEsheet.Columns(1)
    Set LastCell = .Cells(.Cells.Count)
    Set FoundName = .Find(What:=Name, LookAt:=xlWhole, after:=LastCell)
    If Not FoundName Is Nothing Then
        FirstNameAddr = FoundName.Address
        Do
            For Each ctrl In UserForm2.MultiPage1.Pages(1).ConsentsFrame2.Controls
                If ctrl.Name Like "Labelx*" Then
                    For A = 21 To 44
                        Select Case A
                            Case 21, 24, 26, 28, 30, 33, 35, 37, 40, 42, 44 ' # med/mh hx to Crafft screening label
                            Label = UserForm2.Controls("Labelx" & A).Caption
                            Set FoundLabel = DEsheet.Columns(3).Find(What:=Label, LookAt:=xlWhole) 'find the caption of the label on DEsheet column 3
                                If Not FoundLabel Is Nothing Then 'If It is found
                                    UserForm2.Controls("ComboBox" & A).value = FoundLabel.Offset(0, 1).value 'number of notes from column 4 goes in Note ComboBox for that label
                                    UserForm2.Controls("CheckBox" & A).value = True 'checkbox for that label gets checked
                                Else 'if it is not found
                                    UserForm2.Controls("ComboBox" & A).value = vbNullString 'number of notes is blank
                                    UserForm2.Controls("Checkbox" & A).value = False 'yes is not checked
                                    UserForm2.Controls("CheckBoxNo" & A).value = True 'no is checked
                                End If
                                Case Else
                                    'do nothing
                            End Select
                        Next
                    End If
                Next
            Set FoundName = .FindNext(FoundName)
        Loop While Not FoundName Is Nothing And FirstNameAddr <> FoundName.Address
    End If
End With
End Sub

Display More

When Debugging this is the highlighted line

Code

Loop While Not FoundName Is Nothing And FirstNameAddr <> FoundName.Address

The error seems to be with FoundName.Address , as that is the variable showing "object variable or with block variable not set"
Additionally, when i hoover over A, it is showing A = 45.... but it should be 44 and hoovering over the Label variable shows "CRAFFT Screening" which is accurate for Labelx44.Caption.

AKAUFMAN1 · Mar 26th 2018

Hello, the following part of my ListBox1.Click Event REALLY slows down the entire sub. I know there must be a more efficient way to loop through the controls without slowing down the code. Please Help! I am leaving out a lot of the beginning of the event to focus in on what i really need help with. It is also important to note that all of my control names have a number in them that is associated with the column in which the data lives on "Tracking" sheet. When the listbox is selected, i am trying to achieve the following: Based on the value entered in ComboBoxx2 "persons name" , the code will locate the ComboBoxx2 value in DEsheet table6 col 1 , and then if their name is in the table, it will loop through table column 3 checking for the label captions in the ConsentsFrame2. controls. If it finds the label captions in column 3 then it makes the checkbox associated with that label true and takes the value in table column 4 and puts that number in the combobox associated with that label caption. If it does not find the label caption in column 3 then the No checkbox associated with that label caption is marked as true. After all that, it searches for the youths name (ComboBoxx2).value on another sheet in another table MDsheet.ListObjects("Table68"). Loops through table column 2 to find the label captions again and if found, the "MD Signed" checkbox associated with that label caption is marked as true.

Code

Private Sub ListBox1_Click() 
     Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    On Error Resume Next
' i have code here for when list box is selected to fill the text boxes, combo boxes and option buttons with the appropriate data from the worksheet cells
'then more code to select the appropriate row on the main sheet "Tracking"
'more code to use color validation for the boxes based on status of completion
'****************FILL DILIGENT EFFORT BOXES FROM DATA IN SHEET BY FILTERING BY NAME SELECTED IN LISTBOX**************!!SLOW!!!!
Dim Result As Range, MDResult As Range
DEsheet.ListObjects("Table6").Range.AutoFilter Field:=1, Criteria1:=UserForm2.ComboBoxx2.value ' filter diligent efforts table by youths name
For Each ctrl In UserForm2.MultiPage1.Pages(1).ConsentsFrame2.Controls
    If ctrl.Name Like "Labelx*" Then
        For a = 21 To 44 ' #
            Select Case a
                Case 21, 24, 26, 28, 30, 33, 35, 37, 40, 42, 44 
                    With DEsheet
                        FindLabel = UserForm2.Controls("Labelx" & a).Caption
                        Set Result = DEsheet.Columns(3).Find(What:=FindLabel, LookAt:=xlWhole) 'find the caption of the label on DEsheet column 3
                        If Not Result Is Nothing Then 'If It is found
                        DEsheet.Activate 
                        Result.Select ' i believe this line is where it really slows down, im having trouble finding a different way to grab the value it finds though
                        UserForm2.Controls("ComboBox" & a).value = ActiveCell.Offset(0, 1).value 'number of notes from column 4 goes in Note ComboBox for that label
                        UserForm2.Controls("CheckBox" & a).value = True 'checkbox for that label gets checked
                    Else 'if it is not found
                        UserForm2.Controls("ComboBox" & a).value = vbNullString 'number of notes is blank
                        UserForm2.Controls("Checkbox" & a).value = False 'yes is not checked
                        UserForm2.Controls("CheckBoxNo" & a).value = True 'no is checked
                    End If
                End With
                '        ****************FILL MD SIGNED BOXES FROM DATA IN SHEET BY FILTERING BY NAME SELECTED ON LISTBOX*
                MDsheet.ListObjects("Table68").Range.AutoFilter Field:=1, Criteria1:=UserForm2.ComboBoxx2.value ' filter MD table by youths name
                Set MDResult = MDsheet.Columns(3).Find(What:=FindLabel, LookAt:=xlWhole) 'find the caption of the label on MDsheet column 3
                If Not MDResult Is Nothing Then 'If It is found
                MDsheet.Activate
                MDResult.Select 
                UserForm2.Controls("TextBoxx" & a).value = ActiveCell.Offset(0, 1).value 'date of signature from MD table
                UserForm2.Controls("CheckBoxx" & a).value = True 'MD checkbox for that label gets checked
            Else 'if it is not found
                UserForm2.Controls("CheckBoxx" & a).value = False 'MD box not checked
            End If
        Case Else
    End Select
Next
End If
Next


    On Error GoTo 0
endmacro:
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

Display More

AKAUFMAN1 · Feb 9th 2018

Hello! This is my first post here! I have been using this site for about a year now and it has been a tremendous resource.
I am usually able to figure out my questions on my own but after several days of googling my current problem, i am still very stuck.
My UserForm (UserForm1) is almost fully functional with the exception of one problem:
My objective: When clicking the Search button, the listbox will display results for only "Active" records and the other search criteria identified. The user searches for a record, by making their selections in both Combo Boxes (Combobox1 and ComboBox15), then they can click the checkbox (CheckBox2) to filter column F by "Active".

Problem: I am able to get the code to filter the sheet "Assessment.Tracking" to reflect the value of selection made in ComboBox.15 according to the column associated with ComboBox1.value and to reflect the CheckBox2 value of True ("Active") in column F, but for some reason the ListBox(ListBox1) is not reflecting the correct List.Count or the correct rows in the ListBox.List. It is not accounting for a few of the rows that do in fact meet the criteria of both the ComboBox15.value and the CheckBox2.Value.

Code

Private Sub UserForm_Initialize()
Dim ws As Worksheet
Set ws = Sheets("Assessment.Tracking")
    
    Sheets("Assessment.Tracking").Activate
    Call ShowAllData


    '****LISTBOX SET UP***************************
    ListBox1.ColumnWidths = "60;70;150;0;0;60;0;0;0;0;70;0;0;70;0;0;70;0;0;70;0;0;70;0;0;70;0;0;70;0;0;70" 'Keyword:ColumnChange
    ListBox1.ColumnCount = 37 'Keyword:ColumnChange
    ListBox1.List = Sheets("Assessment.Tracking").Range("A2:AF" & Cells(Rows.Count, 1).End(xlUp).Row).value 'Keyword:ColumnChange


    '** SEARCH COMBOBOX SET UP*********************
    ComboBox1.AddItem "Program"
    ComboBox1.AddItem "Youth Name"
    ComboBox1.AddItem "A #"
    ComboBox1.AddItem "Initial Intake"
    ComboBox1.AddItem "PsychoSocial"
    ComboBox1.AddItem "Risk Assessment 1"
    ComboBox1.AddItem "UAC Assessment"
    ComboBox1.AddItem "Initial ISP"
    ComboBox1.AddItem "Risk Assessment 2"
    ComboBox1.AddItem "ISP 2"
    ComboBox1.AddItem "Case Review 1"
    ComboBox1.AddItem "All Assessments"


    '***ASSESSMENT DATES FRAME, ADD SCROLL BARS****
    Call FrameScrollBars
    Call ResetProgressBar
    '***********TOTAL ENTRIES SET
    TextBoxResult.value = ListBox1.ListCount + 1
    
    '****SET THE TEXT BOXES WITH INSTRUCTIONS IN THEM**
    For i = 1 To 23
        If Me.Controls("TextBox" & i).Tag = "date" And Me.Controls("TextBox" & i).value = vbNullString Then
            Me.Controls("TextBox" & i).value = "Click here for calendar"
            Me.Controls("TextBox" & i).Font.Italic = True
            Me.Controls("TextBox" & i).Font.Size = 8
            Me.Controls("TextBox" & i).BackColor = RGB(255, 255, 255)
        End If
    Next
    'CheckBox2.value = False
End Sub
Private Sub ComboBox1_Change() '****WHEN THE SEARCH COMBOBOX SELECTION CHANGES, CHANGE SUB SELECTION COMBO
Call ClearFrameControls
    If ComboBox1.value = "Program" Then
        Me.ComboBox15.RowSource = "ProgramList"
    ElseIf ComboBox1.value = "Youth Name" Then
        Me.ComboBox15.RowSource = "Name"
    ElseIf ComboBox1.value = "A #" Then
        Me.ComboBox15.RowSource = "ANumber"
    Else
        Me.ComboBox15.RowSource = "AssessmentStatus"
    End If
End Sub
Sub ShowAllData()
    If ActiveSheet.FilterMode = False Then
        End If
    If ActiveSheet.FilterMode = True Then
        ActiveSheet.ShowAllData
    End If
End Sub


Private Sub SearchButton_Click() '****SEARCH BUTTON*************************
Dim sat, s As Long
Dim deg1, deg2 As String
deg2 = ComboBox15.value 'search criteria combobox
Dim listObj As ListObject, r%, c%
Set listObj = Sheets("Assessment.Tracking").ListObjects("Table25")




'*****CHECK TO SEE IF COMBOBOXES ARE EMPTY
    If ComboBox15.value = "" And ComboBox1.value <> "All Assessments" Then
        MsgBox "Please enter a search value", vbExclamation
        ComboBox15.SetFocus
        Exit Sub
    End If


    Call ApplicationOff


    If ComboBox1.value = "" Or ComboBox1.value = "-" Then
        MsgBox "Choose a field to search by", vbExclamation
        ComboBox1.SetFocus
        Exit Sub
    End If


Call ClearAllBoxes
Call ProgressBarMain
Call ShowAllData




'****************FILL LIST BOX BASED ON SEARCH
    Select Case ComboBox1.value
        Case "Program"


           
    For sat = 2 To Cells(Rows.Count, 2).End(xlUp).Row 'Program is in Column 2 'Keyword:ColumnChange
    Set deg1 = Cells(sat, "B")
               If deg1 Like deg2 & "*" Then
                    ListBox1.AddItem
                    ListBox1.List(s, 0) = Cells(sat, "A")
                    ListBox1.List(s, 1) = Cells(sat, "B")
                    ListBox1.List(s, 2) = Cells(sat, "C")
                    ListBox1.List(s, 3) = Cells(sat, "D")
                    ListBox1.List(s, 4) = Cells(sat, "E")
                    ListBox1.List(s, 5) = Cells(sat, "F")
                    ListBox1.List(s, 6) = Cells(sat, "G")
                    ListBox1.List(s, 7) = Cells(sat, "H")
                    ListBox1.List(s, 8) = Cells(sat, "I")
                    ListBox1.List(s, 9) = Cells(sat, "J")
                    ListBox1.List(s, 10) = Cells(sat, "K")
                    ListBox1.List(s, 11) = Cells(sat, "L")
                    ListBox1.List(s, 12) = Cells(sat, "M")
                    ListBox1.List(s, 13) = Cells(sat, "N")
                    ListBox1.List(s, 14) = Cells(sat, "O")
                    ListBox1.List(s, 15) = Cells(sat, "P")
                    ListBox1.List(s, 16) = Cells(sat, "Q")
                    ListBox1.List(s, 17) = Cells(sat, "R")
                    ListBox1.List(s, 18) = Cells(sat, "S")
                    ListBox1.List(s, 19) = Cells(sat, "T")
                    ListBox1.List(s, 20) = Cells(sat, "U")
                    ListBox1.List(s, 21) = Cells(sat, "V")
                    ListBox1.List(s, 22) = Cells(sat, "W")
                    ListBox1.List(s, 23) = Cells(sat, "X")
                    ListBox1.List(s, 24) = Cells(sat, "Y")
                    ListBox1.List(s, 25) = Cells(sat, "Z")
                    ListBox1.List(s, 26) = Cells(sat, "AA")
                    ListBox1.List(s, 27) = Cells(sat, "AB")
                    ListBox1.List(s, 28) = Cells(sat, "AC")
                    ListBox1.List(s, 29) = Cells(sat, "AD")
                    ListBox1.List(s, 30) = Cells(sat, "AE")
                    ListBox1.List(s, 31) = Cells(sat, "AF")
                 '   'Keyword:ColumnChange
                s = s + 1
                       
                   End If: Next
                   
                    If CheckBox2.value Then
                        Sheets("Assessment.Tracking").ListObjects("Table25").Range.AutoFilter Field:=2, Criteria1:=deg2 'Filter ListBox and sheet by sub search criteria
                        Sheets("Assessment.Tracking").ListObjects("Table25").Range.AutoFilter Field:=6, Criteria1:="Active" 'Filter ListBox and sheet by all rows in column 6 to Active
                        ListBox1.List = Sheets("Assessment.Tracking").Range("A2:AF" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).value 'Keyword:ColumnChange
                        Label15.Caption = ListBox1.ListCount & " Records Found"
            
                    Else
                        Sheets("Assessment.Tracking").ListObjects("Table25").Range.AutoFilter Field:=2, Criteria1:=deg2
                        ListBox1.List = Sheets("Assessment.Tracking").Range("A2:AF" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).value 'Keyword:ColumnChange
                        Label15.Caption = ListBox1.ListCount & " Records Found"
                    End If
           
           
         
        
        Case "Youth Name"
            For sat = 2 To Cells(Rows.Count, 3).End(xlUp).Row
            'Keyword:ColumnChange
            Set deg1 = Cells(sat, "C")
                If deg1 Like deg2 & "*" Then
                    ListBox1.AddItem
                    ListBox1.List(s, 0) = Cells(sat, "A")
                    ListBox1.List(s, 1) = Cells(sat, "B")
                    ListBox1.List(s, 2) = Cells(sat, "C")
                    ListBox1.List(s, 3) = Cells(sat, "D")
                    ListBox1.List(s, 4) = Cells(sat, "E")
                    ListBox1.List(s, 5) = Cells(sat, "F")
                    ListBox1.List(s, 6) = Cells(sat, "G")
                    ListBox1.List(s, 7) = Cells(sat, "H")
                    ListBox1.List(s, 8) = Cells(sat, "I")
                    ListBox1.List(s, 9) = Cells(sat, "J")
                    ListBox1.List(s, 10) = Cells(sat, "K")
                    ListBox1.List(s, 11) = Cells(sat, "L")
                    ListBox1.List(s, 12) = Cells(sat, "M")
                    ListBox1.List(s, 13) = Cells(sat, "N")
                    ListBox1.List(s, 14) = Cells(sat, "O")
                    ListBox1.List(s, 15) = Cells(sat, "P")
                    ListBox1.List(s, 16) = Cells(sat, "Q")
                    ListBox1.List(s, 17) = Cells(sat, "R")
                    ListBox1.List(s, 18) = Cells(sat, "S")
                    ListBox1.List(s, 19) = Cells(sat, "T")
                    ListBox1.List(s, 20) = Cells(sat, "U")
                    ListBox1.List(s, 21) = Cells(sat, "V")
                    ListBox1.List(s, 22) = Cells(sat, "W")
                    ListBox1.List(s, 23) = Cells(sat, "X")
                    ListBox1.List(s, 24) = Cells(sat, "Y")
                    ListBox1.List(s, 25) = Cells(sat, "Z")
                    ListBox1.List(s, 26) = Cells(sat, "AA")
                    ListBox1.List(s, 27) = Cells(sat, "AB")
                    ListBox1.List(s, 28) = Cells(sat, "AC")
                    ListBox1.List(s, 29) = Cells(sat, "AD")
                    ListBox1.List(s, 30) = Cells(sat, "AE")
                    ListBox1.List(s, 31) = Cells(sat, "AF")
                    'Keyword:ColumnChange
            s = s + 1
        End If: Next


    Case "A #"
        For sat = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        'Keyword:ColumnChange
        Set deg1 = Cells(sat, "A")
            If deg1 Like deg2 & "*" Then
                ListBox1.AddItem
                ListBox1.List(s, 0) = Cells(sat, "A")
                ListBox1.List(s, 1) = Cells(sat, "B")
                ListBox1.List(s, 2) = Cells(sat, "C")
                ListBox1.List(s, 3) = Cells(sat, "D")
                ListBox1.List(s, 4) = Cells(sat, "E")
                ListBox1.List(s, 5) = Cells(sat, "F")
                ListBox1.List(s, 6) = Cells(sat, "G")
                ListBox1.List(s, 7) = Cells(sat, "H")
                ListBox1.List(s, 8) = Cells(sat, "I")
                ListBox1.List(s, 9) = Cells(sat, "J")
                ListBox1.List(s, 10) = Cells(sat, "K")
                ListBox1.List(s, 11) = Cells(sat, "L")
                ListBox1.List(s, 12) = Cells(sat, "M")
                ListBox1.List(s, 13) = Cells(sat, "N")
                ListBox1.List(s, 14) = Cells(sat, "O")
                ListBox1.List(s, 15) = Cells(sat, "P")
                ListBox1.List(s, 16) = Cells(sat, "Q")
                ListBox1.List(s, 17) = Cells(sat, "R")
                ListBox1.List(s, 18) = Cells(sat, "S")
                ListBox1.List(s, 19) = Cells(sat, "T")
                ListBox1.List(s, 20) = Cells(sat, "U")
                ListBox1.List(s, 21) = Cells(sat, "V")
                ListBox1.List(s, 22) = Cells(sat, "W")
                ListBox1.List(s, 23) = Cells(sat, "X")
                ListBox1.List(s, 24) = Cells(sat, "Y")
                ListBox1.List(s, 25) = Cells(sat, "Z")
                ListBox1.List(s, 26) = Cells(sat, "AA")
                ListBox1.List(s, 27) = Cells(sat, "AB")
                ListBox1.List(s, 28) = Cells(sat, "AC")
                ListBox1.List(s, 29) = Cells(sat, "AD")
                ListBox1.List(s, 30) = Cells(sat, "AE")
                ListBox1.List(s, 31) = Cells(sat, "AF")
                'Keyword:ColumnChange
            s = s + 1
        End If: Next




    Case "Initial Intake"
        For sat = 2 To Cells(Rows.Count, 11).End(xlUp).Row
        'Keyword:ColumnChange
        Set deg1 = Cells(sat, "K")
            If deg1 Like deg2 & "*" Then 'if the cell in column K match the sub search term "on time","due soon" etc. then add these rows
                ListBox1.AddItem
                ListBox1.List(s, 0) = Cells(sat, "A")
                ListBox1.List(s, 1) = Cells(sat, "B")
                ListBox1.List(s, 2) = Cells(sat, "C")
                ListBox1.List(s, 3) = Cells(sat, "D")
                ListBox1.List(s, 4) = Cells(sat, "E")
                ListBox1.List(s, 5) = Cells(sat, "F")
                ListBox1.List(s, 6) = Cells(sat, "G")
                ListBox1.List(s, 7) = Cells(sat, "H")
                ListBox1.List(s, 8) = Cells(sat, "I")
                ListBox1.List(s, 9) = Cells(sat, "J")
                ListBox1.List(s, 10) = Cells(sat, "K")
                ListBox1.List(s, 11) = Cells(sat, "L")
                ListBox1.List(s, 12) = Cells(sat, "M")
                ListBox1.List(s, 13) = Cells(sat, "N")
                ListBox1.List(s, 14) = Cells(sat, "O")
                ListBox1.List(s, 15) = Cells(sat, "P")
                ListBox1.List(s, 16) = Cells(sat, "Q")
                ListBox1.List(s, 17) = Cells(sat, "R")
                ListBox1.List(s, 18) = Cells(sat, "S")
                ListBox1.List(s, 19) = Cells(sat, "T")
                ListBox1.List(s, 20) = Cells(sat, "U")
                ListBox1.List(s, 21) = Cells(sat, "V")
                ListBox1.List(s, 22) = Cells(sat, "W")
                ListBox1.List(s, 23) = Cells(sat, "X")
                ListBox1.List(s, 24) = Cells(sat, "Y")
                ListBox1.List(s, 25) = Cells(sat, "Z")
                ListBox1.List(s, 26) = Cells(sat, "AA")
                ListBox1.List(s, 27) = Cells(sat, "AB")
                ListBox1.List(s, 28) = Cells(sat, "AC")
                ListBox1.List(s, 29) = Cells(sat, "AD")
                ListBox1.List(s, 30) = Cells(sat, "AE")
                ListBox1.List(s, 31) = Cells(sat, "AF")
                'Keyword:ColumnChange
        s = s + 1
    End If: Next
 Case "All Assessments"
            For c = 1 To listObj.ListColumns.Count
            For r = 2 To listObj.ListRows.Count
                If listObj.DataBodyRange.Cells(r, c).value = "OVERDUE" Then
                    ListBox1.AddItem
                    ListBox1.List(s, 0) = Cells(r, "A")
                    ListBox1.List(s, 1) = Cells(r, "B")
                    ListBox1.List(s, 2) = Cells(r, "C")
                    ListBox1.List(s, 3) = Cells(r, "D")
                    ListBox1.List(s, 4) = Cells(r, "E")
                    ListBox1.List(s, 5) = Cells(r, "F")
                    ListBox1.List(s, 6) = Cells(r, "G")
                    ListBox1.List(s, 7) = Cells(r, "H")
                    ListBox1.List(s, 8) = Cells(r, "I")
                    ListBox1.List(s, 9) = Cells(r, "J")
                    ListBox1.List(s, 10) = Cells(r, "K")
                    ListBox1.List(s, 11) = Cells(r, "L")
                    ListBox1.List(s, 12) = Cells(r, "M")
                    ListBox1.List(s, 13) = Cells(r, "N")
                    ListBox1.List(s, 14) = Cells(r, "O")
                    ListBox1.List(s, 15) = Cells(r, "P")
                    ListBox1.List(s, 16) = Cells(r, "Q")
                    ListBox1.List(s, 17) = Cells(r, "R")
                    ListBox1.List(s, 18) = Cells(r, "S")
                    ListBox1.List(s, 19) = Cells(r, "T")
                    ListBox1.List(s, 20) = Cells(r, "U")
                    ListBox1.List(s, 21) = Cells(r, "V")
                    ListBox1.List(s, 22) = Cells(r, "W")
                    ListBox1.List(s, 23) = Cells(r, "X")
                    ListBox1.List(s, 24) = Cells(r, "Y")
                    ListBox1.List(s, 25) = Cells(r, "Z")
                    ListBox1.List(s, 26) = Cells(r, "AA")
                    ListBox1.List(s, 27) = Cells(r, "AB")
                    ListBox1.List(s, 28) = Cells(r, "AC")
                    ListBox1.List(s, 29) = Cells(r, "AD")
                    ListBox1.List(s, 30) = Cells(r, "AE")
                    ListBox1.List(s, 31) = Cells(sat, "AF")
                    'Keyword:ColumnChange
                s = s + 1
            End If
        Next
        Next


    End Select


Call ApplicationOn
'*************SET LABEL TO SHOW COUNT OF RECORDS FOUND
Label15.Caption = ListBox1.ListCount & " " & "Records" & " " & "Found"
End Sub


Private Sub CheckBox2_Change()
  Call ShowAllData
    If CheckBox2.value = True Then    'Filter ListBox1.Index by all rows in column 6 to Active
        Sheets("Assessment.Tracking").ListObjects("Table25").Range.AutoFilter Field:=6, Criteria1:="Active"
        ListBox1.List = Sheets("Assessment.Tracking").Range("A2:AF" & Cells(Rows.Count, 6).End(xlUp).Row).SpecialCells(xlCellTypeVisible).value 'Keyword:ColumnChange
        Label15.Caption = ListBox1.ListCount + 1 & " Records Found"
    ElseIf CheckBox2.value = False Then
        ActiveSheet.ListObjects("Table25").Range.AutoFilter Field:=6
        ListBox1.List = Sheets("Assessment.Tracking").Range("A2:AF" & Cells(Rows.Count, 6).End(xlUp).Row).SpecialCells(xlCellTypeVisible).value 'Keyword:ColumnChange
        Label15.Caption = ListBox1.ListCount + 1 & " Records Found"
End If
End Sub


Sub ApplicationOff()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
End Sub
Sub ApplicationOn()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Display More

I have tried this with and without the checkbox2 change event and it seems to be yielding the same results.
I have also attached the workbook.
Thank you in advance for any help offered!

Posts by AKAUFMAN1

Generating Recurring Due Dates Based on Age and Varying Frequencies

Passing a Range Variable Into a Parameter

Auto select previously selected listbox item in multicolumn listbox after refreshing

Selection Change Event, Set New Dynamic Ranges and Loop

Changing UserForm Control Names Based on Column Numbers

Changing UserForm Control Names Based on Column Numbers

Changing UserForm Control Names Based on Column Numbers

A userform technique for the adv users...

Changing UserForm Control Names Based on Column Numbers

Changing UserForm Control Names Based on Column Numbers

ListBox Click VERY SLOW when looping through multiple controls

Changing UserForm Control Names Based on Column Numbers

Changing UserForm Control Names Based on Column Numbers

ListBox Click VERY SLOW when looping through multiple controls

ListBox Click VERY SLOW when looping through multiple controls

ListBox.List not matching CheckBox & ComboBox criteria after correctly filtered sheet