Faster Filtering In User Form

[Puertorekinsam]

Greetings all,

I am building a user form to create some drill-able dashboard ranking functionality. I am using a user form so I can control the look and feel and functionality better than a pivot table.

That being said, I'm finding the functions a bit slow.

I currently have two sheets of data that I am working with.

On one Sheet, I have a complete hierarchy of my company where columns A = the Region Code, B= the Region Name, C= District Code, D= District Name, E= State Code, F= State Name, G=Store Code, H=Store Name, I= Department Code, J= Department Name, K=Shift Code, L= Shift Name, M=Employee Status Code, N= Employee Status Name, O= Employee ID, P= Employee Name

On the second Sheet, I have all the Unique Values from the "Name" columns on the original sheet. For example, There are 4 Districts that have stores in California, California only appears once in the second sheet.


I was to have a series of combo boxes that let me drill down the hierarchy

When I activate the userform, I populate the first drill down with all six Region Names from the second sheet.
When i choose a region from the first box, I want to populate the second box with the unique district names... etc... etc... through all the boxes. I have built some code that lets me do that, but once I get through the third level it takes a while to calculate and populate the boxes.

If any one has and ideas on how I can improve the speed, I would appreciate it.

Private Sub UserForm_Activate()

' ListSheet is the name of the sheet that contains the unique values.
' HeirSheet is the name of the sheet with the complete heirachy
If ListSheet Is Nothing Then Call Create_List_Page

        j = 2
    Do Until ListSheet.Cells(j, 1) = ""
        Me.Combo_H1.AddItem (ListSheet.Cells(j, 1))
        j = j + 1
    Loop
End Sub


' This is the main code that runs when a selection is changed in one of the drop downboxes.  I will be adding more code to clean up which boxes are visible etc... Once I get the speed better.
Sub ChangeHeirCombo(ComboName As String, ComboNum As Integer)
    Application.ScreenUpdating = False
    ' Make sure a selection was made
    If Me.Controls(ComboName) <> "" Then
        ' Store the selected value from the drop downs... Since I was in testing I wanted to have a simple place to see these, and not lose them if I kill the code.
        ListSheet.Cells(ComboNum, 22) = Me.Controls(ComboName)
        
        ' Clean out any names that were in the combo box from the last time it was updated
        Do Until Me.Controls("Combo_H" & (ComboNum + 1)).ListCount = 0
            Me.Controls("Combo_H" & (ComboNum + 1)).RemoveItem (0)
        Loop
        
        ' The Heirachy's have headers, so I want to start in the second row
        HierLevel = 2
        ' Depending on how deep the level is, I built out a COUNTIFS formula to make sure all the previous selections are accounted for
        FirstFormulaPart = ""
        For k = 0 To ComboNum - 1
            FirstFormulaPart = FirstFormulaPart + HeirName & "!" & Chr(66 + k * 2) & ":" & Chr(66 + k * 2) & "," & "'Unique List'!$V$" & (k + 1) & ","
        Next
        
        ' Once the previous selections are accounted for, I loop through all the unique values in the next level of the heirachy. Sometimes a rogue blank appears in the middle of the data, so I loop until I find 3 blank rows in a row for now.
        Do Until ListSheet.Cells(HierLevel, 1 + 2 * (ComboNum)) = "" And ListSheet.Cells(HierLevel + 1, 1 + 2 * (ComboNum)) = ""
           
            'I take the first part of the formula from above, and put it in the COUNTIFs and account for the name in the row.
            ListSheet.Cells(HierLevel, 2 + 2 * (ComboNum)).Formula = "=Countifs(" & FirstFormulaPart & HeirName & "!" & Chr(66 + (ComboNum) * 2) & ":" & Chr(66 + (ComboNum) * 2) & ",'Unique List'!" & Chr(65 + (ComboNum) * 2) & HierLevel & ")"
            'I thought having all those countifs on the page could be part of my problem, calculating every time a new one is added... so I copy the value out and paste it in it's place
            ListSheet.Cells(HierLevel, 2 + 2 * (ComboNum)).Copy
            ListSheet.Cells(HierLevel, 2 + 2 * (ComboNum)).PasteSpecial xlPasteValues
            'I then look at the count of the values. If there is one or more, I add it to the drop down
            If ListSheet.Cells(HierLevel, 2 + 2 * (ComboNum)) > 0 Then
                Me.Controls("Combo_H" & (ComboNum + 1)).AddItem (ListSheet.Cells(HierLevel, 1 + 2 * (ComboNum)))
            End If
            ' go to the next row in the heirachy level.
            HierLevel = HierLevel + 1
        Loop
        
    End If
        Application.ScreenUpdating = True
End Sub

' Below are the different comboboxes that call the code above.

Private Sub Combo_H1_Change()
    Call ChangeHeirCombo("Combo_H1", 1)
End Sub
Private Sub Combo_H2_Change()
    Call ChangeHeirCombo("Combo_H2", 2)
End Sub
Private Sub Combo_H3_Change()
    Call ChangeHeirCombo("Combo_H3", 3)
End Sub
Private Sub Combo_H4_Change()
    Call ChangeHeirCombo("Combo_H4", 4)
End Sub
Private Sub Combo_H5_Change()
    Call ChangeHeirCombo("Combo_H5", 5)
End Sub
Private Sub Combo_H6_Change()
    Call ChangeHeirCombo("Combo_H6", 6)
End Sub
Private Sub Combo_H7_Change()
    Call ChangeHeirCombo("Combo_H7", 7)
End Sub
Private Sub Combo_H8_Change()
    Call ChangeHeirCombo("Combo_H8", 8)
End Sub

 

[Puertorekinsam]

Well after a week, I was able to get something to work. This is much faster, but does require manipulation of the filters on the page.

' This is the main code that runs when a selection is changed in one of the drop downboxes.  I will be adding more code to clean up which boxes are visible etc... Once I get the speed better.
Sub ChangeHeirComboTake2(ComboName As String, ComboNum As Integer)
    Application.ScreenUpdating = False
    ' Make sure a selection was made
    If Me.Controls(ComboName).ListCount <> "" And Me.Controls("Combo_H" & (ComboNum)).Visible = True Then
        Me.LB_Next.Clear
        ' Store the selected value from the drop downs... Since I was in testing I wanted to have a simple place to see these, and not lose them if I kill the code.
        ListSheet.Cells(ComboNum, 22) = Me.Controls(ComboName)
        
        ' Clean out any names that were in the combo box from the last time it was updated
        For i = 10 To ComboNum + 1 Step -1
             Me.Controls("Combo_H" & (i)).Visible = False
             Me.Controls("Label_H" & (i)).Visible = False
        Do Until Me.Controls("Combo_H" & (i)).ListCount = 0
            
            Me.Controls("Combo_H" & (i)).RemoveItem (0)
        Loop
            Me.Controls("Combo_H" & (i)) = ""
        Next

        If Not HeirSheet.AutoFilterMode Then HeirSheet.Range("A1").AutoFilter
        If ActiveSheet.FilterMode Then
          ActiveSheet.ShowAllData
        End If
        For i = 1 To ComboNum
            HeirSheet.Range("$A:$R").AutoFilter Field:=(2 * i), Criteria1:=Me.Controls("Combo_H" & i)
        Next
        

        
        
        
        ' The Heirachy's have headers, so I want to start in the second row
        x = x
        Set FindRow = HeirSheet.Columns(2 * ComboNum).Find(Me.Controls(ComboName))
        RowNum = Range(FindRow.Address).Row
        
        Do
            HeirSheet.Cells(RowNum, 2 * ComboNum).Select
            NextCat = HeirSheet.Cells(RowNum, (2 * (1 + ComboNum)))
            Me.Controls("Combo_H" & (ComboNum + 1)).AddItem (NextCat)
            Me.LB_Next.AddItem (NextCat)
            Me.LB_Next.Tag = ComboNum + 1
            Set FindRow = HeirSheet.Columns(2 * (1 + ComboNum)).Find(NextCat, searchDirection:=xlPrevious)
            RowNum = Range(FindRow.Address).Row + 1
        Loop Until HeirSheet.Cells(RowNum, 2 * ComboNum) <> Me.Controls(ComboName) And HeirSheet.Cells(RowNum + 1, 2 * ComboNum) <> Me.Controls(ComboName)
        If Me.Controls("Combo_H" & (ComboNum + 1)).ListCount > 1 Then
            Me.Controls("Combo_H" & (ComboNum + 1)).Visible = True
            Me.Controls("Label_H" & (ComboNum + 1)).Visible = True

        End If
    End If
        Application.ScreenUpdating = True
End Sub