Help With Filtering For ListBox

T

TellM1955

New Member
Joined
Apr 8, 2021
Messages
38
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
A request for assistance.

The workbork attached below has a form within that has been built using snippets of code from the web. You will probably see that my knowledge of VBA is extremely limited so I'm reaching out for assistance.

What I'm trying to achieve is; using the FilterData macro, filter the Comboboxes of Route and When and populate the Listbox for me to select records for editing. However, when I run the code it always exits the sub on the following line:

VBA Code: 
If .ComboBoxRoute.ListIndex < 0 Or .ComboBoxWhen.ListIndex < 0 Then Exit Sub

So any assistance would be greatly appreciated

Thanks

Filter For ListBox
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Sort by date Sort by votes
Replace all your code from userform to this:

VBA Code: 
Private Sub AddDataToListBox()

'Get the required data

  Dim rg As Range
  If ShRouteData.AutoFilterMode Then ShRouteData.AutoFilterMode = False
  Set rg = GetRangeRoute
  
  ' Me.ComboBoxRoute.List = GetRouteAM()
   ' Me.ComboBoxRoute.ListIndex = -1
  
'Link Data to Listbox
  
  With ListBoxRoutes

    '.RowSource = rg.Address(external:=True)
    .List = rg.Value
    .ColumnCount = rg.Columns.Count - 1
    .ColumnWidths = "25,110,50,200,40,0"
    .ColumnHeads = False
    .ListIndex = 0
  
  End With
      

End Sub

Private Sub ComBAdd_Click()

Dim sh As Worksheet
Set sh = ShRouteData
Dim lr As Long
lr = Application.WorksheetFunction.CountA(sh.Range("A:A"))

'Validation
'**********************************************************
If Me.ComboBoxRoute.Value = "" Then

      MsgBox "Select Route", vbCritical
      Exit Sub
End If
      
If Me.ComboBoxWhen.Value = "" Then

      MsgBox "Select Time", vbCritical
      Exit Sub
End If

If Me.TextBoxPickDrop.Value = "" Then

      MsgBox "Enter Pick Up / Drop Point", vbCritical
      Exit Sub
End If
      
If Me.TextBoxROrder.Value = "" Then

      MsgBox "Enter Route Order", vbCritical
      Exit Sub
End If

If Not IsNumeric(TextBoxROrder) Then

      MsgBox ("Enter a Number"), vbCritical
      Exit Sub
End If
'********************************************************
'Add Data
sh.Range("A" & lr + 1).Value = "=row()-1"
sh.Range("b" & lr + 1).Value = Me.ComboBoxRoute.Value
sh.Range("c" & lr + 1).Value = Me.ComboBoxWhen.Value
sh.Range("d" & lr + 1).Value = Me.TextBoxPickDrop.Value
sh.Range("e" & lr + 1).Value = Me.TextBoxROrder.Value * 1


'Clear after adding
Me.ComboBoxRoute.Value = ""
Me.ComboBoxWhen.Value = ""
Me.TextBoxPickDrop.Value = ""
Me.TextBoxROrder.Value = ""

End Sub

Private Sub ComBClear_Click()

'Clear Fields
Me.ComboBoxRoute.Value = ""
Me.ComboBoxWhen.Value = ""
Me.TextBoxPickDrop.Value = ""
Me.TextBoxROrder.Value = ""
Me.TextBoxID.Value = ""

End Sub

Private Sub ComBClose_Click()
Unload Me
End Sub

Private Sub ComBDelete_Click()

    If MsgBox("Are you sure?", vbOKCancel, "Confirm Delete") = vbOK Then
       Call DeleteRouteRow(ListBoxRoutes.ListIndex)
    End If
  

End Sub

Private Sub ComboBoxRoute_Change()
  Call FilterData
End Sub

Private Sub ComboBoxWhen_Change()
  Call FilterData
End Sub

Private Sub ComBUpdate_Click()


  If Me.TextBoxID.Value = "" Then
  
      MsgBox "Select A Record To Update By Double Clicking It", vbCritical
      Exit Sub
  
  End If
  
Dim sh As Worksheet
Set sh = ShRouteData
Dim Srow As Long
Srow = Application.WorksheetFunction.Match(CLng(Me.TextBoxID.Value), sh.Range("a:A"), 0)



'Validation
'**********************************************************
If Me.ComboBoxRoute.Value = "" Then

      MsgBox "Select Route", vbCritical
      Exit Sub
End If
      
If Me.ComboBoxWhen.Value = "" Then

      MsgBox "Select Time", vbCritical
      Exit Sub
End If

If Me.TextBoxPickDrop.Value = "" Then

      MsgBox "Enter Pick Up / Drop Point", vbCritical
      Exit Sub
End If
      
If Me.TextBoxROrder.Value = "" Then

      MsgBox "Enter Route Order", vbCritical
      Exit Sub
End If

If Not IsNumeric(TextBoxROrder) Then

      MsgBox ("Enter a Number"), vbCritical
      Exit Sub
End If
'********************************************************
'Add Data

sh.Range("b" & Srow).Value = Me.ComboBoxRoute.Value
sh.Range("c" & Srow).Value = Me.ComboBoxWhen.Value
sh.Range("d" & Srow).Value = Me.TextBoxPickDrop.Value
sh.Range("e" & Srow).Value = Me.TextBoxROrder.Value * 1


'Clear after adding
Me.ComboBoxRoute.Value = ""
Me.ComboBoxWhen.Value = ""
Me.TextBoxPickDrop.Value = ""
Me.TextBoxROrder.Value = ""
Me.TextBoxID.Value = ""
      
End Sub



Private Sub ListBoxRoutes_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

'Select Record for Editing

  Me.TextBoxID.Value = Me.ListBoxRoutes.List(Me.ListBoxRoutes.ListIndex, 0)
  Me.ComboBoxRoute.Value = Me.ListBoxRoutes.List(Me.ListBoxRoutes.ListIndex, 1)
  Me.ComboBoxWhen.Value = Me.ListBoxRoutes.List(Me.ListBoxRoutes.ListIndex, 2)
  Me.TextBoxPickDrop.Value = Me.ListBoxRoutes.List(Me.ListBoxRoutes.ListIndex, 3)
  Me.TextBoxROrder.Value = Me.ListBoxRoutes.List(Me.ListBoxRoutes.ListIndex, 4)
  
  
 
End Sub

Private Sub OptBRouteWhen_Click()
Dim sh As Worksheet

Set sh = ShRouteData

If sh.Cells(Rows.Count, 1).End(xlUp).row = 1 Then

  lr = 2
  
Else
  lr = sh.Cells(Rows.Count, 1).End(xlUp).row
End If


'Sort Records by Route & When

Set SortA = sh.Range("a2:f" & lr)

   sh.Sort.SortFields.Clear
  
  sh.Sort.SortFields.Add2 key:=sh.Range("b1:b" & lr), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  sh.Sort.SortFields.Add2 key:=sh.Range("c1:c" & lr), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With sh.Sort
        .SetRange SortA
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Private Sub OptBPickDrop_Click()
'
  'Sort By Drop / Pick
  Set sh = ShRouteData

If sh.Cells(Rows.Count, 1).End(xlUp).row = 1 Then

  lr = 2
  
Else
  lr = sh.Cells(Rows.Count, 1).End(xlUp).row
End If

Set SortA = sh.Range("a2:f" & lr)

  
  
  sh.Sort.SortFields.Clear
  
  sh.Sort.SortFields.Add2 key:=sh.Range("d1:d" & lr), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With sh.Sort
        .SetRange SortA
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


End Sub



Private Sub UserForm_Initialize()

 Call AddDataToListBox
 Call UniqueValues

End Sub

Private Sub UniqueValues()
Dim dict, key
Dim lr As Long
lr = Application.WorksheetFunction.CountA(Range("A:A"))

'Select Unique Records from Routes

With ShRouteData.Range("b2:b" & lr)
    dict = .Value
End With
With CreateObject("scripting.dictionary")
      .comparemode = 1
      For Each key In dict
      
      If Not .exists(key) Then .Add key, Nothing
      
    Next
    If .Count Then Me.ComboBoxRoute.List = Application.Transpose(.keys)
End With

'Select Unique Periods from When

With ShRouteData.Range("c2:c" & lr)
    dict = .Value
End With
With CreateObject("scripting.dictionary")
      .comparemode = 1
      For Each key In dict
      
      If Not .exists(key) Then .Add key, Nothing
      
    Next
    If .Count Then Me.ComboBoxWhen.List = Application.Transpose(.keys)
End With
  


End Sub

Private Sub FilterData()
  Dim route As String, when As String
  Dim mydb As Range
  
  With FrmRouteAdmin
    route = IIf(.ComboBoxRoute.Value = "", "*", .ComboBoxRoute.Value)
    when = IIf(.ComboBoxWhen.Value = "", "*", .ComboBoxWhen.Value)
  End With
  
  With ShRouteData
    Set mydb = .Range("A1:F1").Resize(.Cells(.Rows.Count, 1).End(xlUp).row)
  End With
  
  With mydb
    .AutoFilter
    .AutoFilter Field:=2, Criteria1:=route
    .AutoFilter Field:=3, Criteria1:=when
    Call UpdateListBox(Me.ListBoxRoutes, mydb, 2)
    .AutoFilter
  End With
End Sub

Private Sub UpdateListBox(ListBoxRoutes As MSForms.ListBox, mydb As Range, Columntolist As Long)
  Dim cell As Range, datavalues As Range
  
  If mydb.SpecialCells(xlCellTypeVisible).Count > mydb.Columns.Count Then
    Set datavalues = mydb.Resize(mydb.Rows.Count + 1)
    ListBoxRoutes.Clear
    For Each cell In datavalues.Columns(Columntolist).SpecialCells(xlCellTypeVisible)
      With Me.ListBoxRoutes
        .AddItem cell.Value
        .List(.ListCount - 1, 1) = cell.Offset(0, 1).Value
        .List(.ListCount - 1, 2) = cell.Offset(0, 2).Value
        .List(.ListCount - 1, 3) = cell.Offset(0, 3).Value
        .List(.ListCount - 1, 4) = cell.Offset(0, 2).Value
        .List(.ListCount - 1, 5) = cell.Offset(0, 3).Value
      End With
    Next cell
  Else
    ListBoxRoutes.Clear
  End If
  ListBoxRoutes.SetFocus
End Sub

Note: Don't use rowsource if you are going to use the .Additem method, you will have problems.

🤗
 
Upvote 0
Solution
Dante, many thanks for this coding, it works perfectly in the sample file I sent. However, I'm getting an error when I copy it over to my main file and run it.

This is the error that pops up
1730030395300.png

The code stops running at the following line:

1730030463454.png


Do you have any idea as to why and more importantly what I need to to do to correct it?

Regards
 
Upvote 0
Dante, I've managed to resolve. This issue was that I had some formula in columns alongside the table. Now that I've removed them it works perfectly.

Once again many thanks for your help.
 
Upvote 1
You must log in or register to reply here.

Similar threads

P
  • Question Question
Listbox Filter Search
Replies
5
Views
470
Pacman52
P
J
  • Solved
Filter a listbox containing 12 columns using a single searchbox
Replies
8
Views
774
Anthony47
A
R
  • Solved
Add Filtered Data to a ListBox in Userform
Replies
5
Views
1K
NoSparks
N
M
  • Question Question
Userform listbox not populating when userform is first opened
Replies
1
Views
525
Trevor G
Trevor G
V
  • Solved
VBA search in listbox when used combobox and textbox-To be modified
2
Replies
13
Views
962
velu888
V

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

Share this page

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