Listbox Filter using a combobox

[BradFoxii]

Hi im,

currently making a userform that filters all data based off of a combobox value which works but only pulls 1 row of data instead of all rows with the same cell value I.E Column A.

I'm trying to have it search for the combobox criteria in Column A and display all rows with the same cell value in the listbox.


This is my current code and a snippet of the userform.

Option Explicit

Dim ws As Worksheet
Dim lrow As Long
Dim i As Long, j As Long
Private Sub UserForm_Initialize()
    '~~> Set this to the relevant worksheet
    Set ws = Worksheets("total sheet")
    
    '~~> Set the listbox column count
    AllocateBox1.ColumnCount = 13
    
    Dim col As New Collection
    Dim itm As Variant
    
    With ws
        '~~> Get last row in column C
        lrow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Create a unique list from column C values
        On Error Resume Next
        For i = 1 To lrow
            col.Add .Range("A" & i).Value2, CStr(.Range("A" & i).Value2)
        Next i
        On Error GoTo 0
        
        '~~> Add the item to combobox
        For Each itm In col
            ComboBox1.AddItem itm
        Next itm
    End With
End Sub
Private Sub CommandButton1_Click()
    '~~> If nothing selected in the combobox then exit
    If ComboBox1.ListIndex = -1 Then Exit Sub
    
    '~~> Clear the listbox
    AllocateBox1.Clear
    
    Dim DataRange As Range, rngArea As Range
    Dim DataSet As Variant
    
    With ws
        '~~> Remove any filters
        .AutoFilterMode = False
        
        '~~> Find last row in Col A
        lrow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Filter on the relevant column
        With .Range("A" & lrow)
            .AutoFilter Field:=1, Criteria1:=ComboBox1.Value
            
            On Error Resume Next
            Set DataRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
            On Error GoTo 0
        End With
        
        '~~> Check if the autofilter returned any results
        If Not DataRange Is Nothing Then
            '~~> Instead of using another object, I am reusing the object
            Set DataRange = .Range("A1:M" & lrow).SpecialCells(xlCellTypeVisible)
            
            '~~> Create the array
            ReDim DataSet(1 To DataRange.Areas.Count + 1, 1 To 13)
            
            j = 1
            
            '~~> Loop through the area and store in the array
            For Each rngArea In DataRange.Areas
                For i = 1 To 13
                    DataSet(j, i) = rngArea.Cells(, i).Value2
                Next i
                j = j + 1
            Next rngArea
            
            '~~> Set the listbox list
            AllocateBox1.List = DataSet
        End If
        
        '~~> Remove any filters
        .AutoFilterMode = False
    End With
End Sub


Private Sub Escbtn_Click()

Unload Me
    
End Sub

 

[DanteAmor]

Try the following.
It uses a dictionary object to load the unique values into the combo.
It uses an array to read the data from the sheet. The sheet data is loaded into memory in the matrix, thus reading and/or filtering the information is faster.
I added the code to read the data and verify which ones match in the combo event, in this way automatically every time you select a combo data the information is presented, a button is no longer necessary.

Replace all your code with the following:

Option Explicit

Dim ws As Worksheet
Dim a As Variant
Dim dic As Object

Private Sub ComboBox1_Change()
  Dim b As Variant
  Dim i As Long, j As Long, k As Long, n As Long
  
  AllocateBox1.Clear
  If ComboBox1.ListIndex = -1 Then Exit Sub
  
  n = dic(ComboBox1.Value)
  ReDim b(1 To n, 1 To UBound(a, 2))
  For i = 2 To UBound(a, 1)
    If a(i, 1) = ComboBox1.Value Then
      k = k + 1
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next
    End If
  Next
  AllocateBox1.List = b
End Sub

Private Sub UserForm_Initialize()
  Dim i As Long
  
  Set ws = Worksheets("total sheet")    '~~> Set this to the relevant worksheet
  Set dic = CreateObject("Scripting.Dictionary")
  
  a = ws.Range("A1:M" & ws.Range("A" & Rows.Count).End(3).Row).Value
  AllocateBox1.ColumnCount = UBound(a, 2)        '~~> Set the listbox column count
  
  For i = 1 To UBound(a, 1)
    dic(a(i, 1)) = dic(a(i, 1)) + 1
  Next
  ComboBox1.List = dic.keys
End Sub

Private Sub Escbtn_Click()
  Unload Me
End Sub