Populate an ActiveX combo box according to a List Box values

brendalpzm

brendalpzm

Board Regular
Joined
Oct 3, 2022
Messages
59
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
Platform
  1. Windows
I have a ListBox that is filtered by a TextBox, but I want it ot be filter by a ComboBox as well, This means that If the TextBox is filtering specific values, the values shown in the ListBox must be shown in the ComboBox.

This is a visual example of it
1696353036149.png

And this is the code that I'm using for the filter if it's useful for reference

VBA Code: 
Option Explicit

Dim arrdata() As Variant        'at the beginning of all the code

Private Sub ModelCB_Change()
  Call Filter_Data
End Sub

Private Sub UserFilter_Change()
  Call Filter_Data
End Sub

Sub Filter_Data()
  Dim i As Long, lngrow As Long
  Dim tbox As String, cbox As String

  Me.CarList.Clear
  lngrow = 0
  For i = LBound(arrdata, 1) + 1 To UBound(arrdata, 1)
    If UserFilter.Value = "" Then tbox = LCase(arrdata(i, 5)) Else tbox = LCase(UserFilter.Value)
    If ModelCB.Value = "" Then cbox = LCase(arrdata(i, 3)) Else cbox = LCase(ModelCB.Value)
   
    If arrdata(i, 13) <> "completed" And LCase(arrdata(i, 5)) Like "*" & tbox & "*" And _
       LCase(arrdata(i, 3)) = cbox Then
      Call add_ToListbox(lngrow, i)
      lngrow = lngrow + 1
    End If
  Next
End Sub

Private Sub UserForm_Initialize()
  Dim lngindex As Long
  Dim lngrow As Long
 
  arrdata = Worksheets("Current").Range("A1").CurrentRegion.Value
 
  With Me.lstHeaders
    .ColumnCount = 7
    .ColumnWidths = "180;60;255;95;75;105;65"
    .Font.Size = 13
    .Font.Bold = True
    .Enabled = False
     .AddItem
    .List(lngrow, 0) = arrdata(1, 3)
    .List(lngrow, 1) = arrdata(1, 4)
    .List(lngrow, 2) = arrdata(1, 5)
    .List(lngrow, 3) = arrdata(1, 10)
    .List(lngrow, 4) = arrdata(1, 11)
    .List(lngrow, 5) = arrdata(1, 13)
    .List(lngrow, 6) = arrdata(1, 14)
  End With
 
  With Me.CarList
    .ColumnCount = 7
    .ColumnWidths = "180;60;255;95;75;105;65"
    .Font.Size = 13
  End With
 
  lngrow = 0
  For lngindex = LBound(arrdata, 1) + 1 To UBound(arrdata, 1)
    If arrdata(lngindex, 13) <> "completed" Then
      Call add_ToListbox(lngrow, lngindex)
      lngrow = lngrow + 1
    End If
  Next lngindex
End Sub

Sub add_ToListbox(lngrow, lngindex)
  With Me.CarList
    .AddItem
    .List(lngrow, 0) = arrdata(lngindex, 3)
    .List(lngrow, 1) = arrdata(lngindex, 4)
    .List(lngrow, 2) = arrdata(lngindex, 5)
    .List(lngrow, 3) = arrdata(lngindex, 10)
    .List(lngrow, 4) = arrdata(lngindex, 11)
    .List(lngrow, 5) = arrdata(lngindex, 13)
    .List(lngrow, 6) = arrdata(lngindex, 14)
    End With
End Sub
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Sort by date Sort by votes
Replace all your code for this, contains the code to load the ModelCB from start.


VBA Code: 
Option Explicit

Dim arrdata() As Variant        'at the beginning of all the code

Private Sub ModelCB_Change()
  Call Filter_Data
End Sub

Private Sub UserFilter_Change()
  Dim dic As Object
  Dim i As Long
  
  Set dic = CreateObject("Scripting.Dictionary")

  Call Filter_Data
  
  For i = 0 To CarList.ListCount - 1
    If Not dic.exists(CarList.List(i, 0)) Then
      dic(CarList.List(i, 0)) = Empty
    End If
  Next
  
  ModelCB.List = dic.keys
End Sub

Sub Filter_Data()
  Dim i As Long, lngrow As Long
  Dim tbox As String, cbox As String

  Me.CarList.Clear
  lngrow = 0
  For i = LBound(arrdata, 1) + 1 To UBound(arrdata, 1)
    If UserFilter.Value = "" Then tbox = LCase(arrdata(i, 5)) Else tbox = LCase(UserFilter.Value)
    If ModelCB.Value = "" Then cbox = LCase(arrdata(i, 3)) Else cbox = LCase(ModelCB.Value)
   
    If arrdata(i, 13) <> "completed" And LCase(arrdata(i, 5)) Like "*" & tbox & "*" And _
       LCase(arrdata(i, 3)) = cbox Then
      Call add_ToListbox(lngrow, i)
      lngrow = lngrow + 1
    End If
  Next
End Sub

Private Sub UserForm_Initialize()
  Dim lngindex As Long
  Dim lngrow As Long
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  arrdata = Worksheets("Current").Range("A1").CurrentRegion.Value
 
  With Me.lstHeaders
    .ColumnCount = 7
    .ColumnWidths = "180;60;255;95;75;105;65"
    .Font.Size = 13
    .Font.Bold = True
    .Enabled = False
     .AddItem
    .List(lngrow, 0) = arrdata(1, 3)
    .List(lngrow, 1) = arrdata(1, 4)
    .List(lngrow, 2) = arrdata(1, 5)
    .List(lngrow, 3) = arrdata(1, 10)
    .List(lngrow, 4) = arrdata(1, 11)
    .List(lngrow, 5) = arrdata(1, 13)
    .List(lngrow, 6) = arrdata(1, 14)
  End With
 
  With Me.CarList
    .ColumnCount = 7
    .ColumnWidths = "180;60;255;95;75;105;65"
    .Font.Size = 13
  End With
 
  lngrow = 0
  For lngindex = LBound(arrdata, 1) + 1 To UBound(arrdata, 1)
    If arrdata(lngindex, 13) <> "completed" Then
      Call add_ToListbox(lngrow, lngindex)
      
      If Not dic.exists(arrdata(lngindex, 3)) Then
        dic(arrdata(lngindex, 3)) = Empty
      End If
      
      lngrow = lngrow + 1
    End If
  Next lngindex
  
  ModelCB.List = dic.keys
End Sub

Sub add_ToListbox(lngrow, lngindex)
  With Me.CarList
    .AddItem
    .List(lngrow, 0) = arrdata(lngindex, 3)
    .List(lngrow, 1) = arrdata(lngindex, 4)
    .List(lngrow, 2) = arrdata(lngindex, 5)
    .List(lngrow, 3) = arrdata(lngindex, 10)
    .List(lngrow, 4) = arrdata(lngindex, 11)
    .List(lngrow, 5) = arrdata(lngindex, 13)
    .List(lngrow, 6) = arrdata(lngindex, 14)
    End With
End Sub

Regards
Dante Amor
 
Upvote 1
Solution
DanteAmor said:
Replace all your code for this, contains the code to load the ModelCB from start.


VBA Code: 
Option Explicit

Dim arrdata() As Variant        'at the beginning of all the code

Private Sub ModelCB_Change()
  Call Filter_Data
End Sub

Private Sub UserFilter_Change()
  Dim dic As Object
  Dim i As Long
 
  Set dic = CreateObject("Scripting.Dictionary")

  Call Filter_Data
 
  For i = 0 To CarList.ListCount - 1
    If Not dic.exists(CarList.List(i, 0)) Then
      dic(CarList.List(i, 0)) = Empty
    End If
  Next
 
  ModelCB.List = dic.keys
End Sub

Sub Filter_Data()
  Dim i As Long, lngrow As Long
  Dim tbox As String, cbox As String

  Me.CarList.Clear
  lngrow = 0
  For i = LBound(arrdata, 1) + 1 To UBound(arrdata, 1)
    If UserFilter.Value = "" Then tbox = LCase(arrdata(i, 5)) Else tbox = LCase(UserFilter.Value)
    If ModelCB.Value = "" Then cbox = LCase(arrdata(i, 3)) Else cbox = LCase(ModelCB.Value)
  
    If arrdata(i, 13) <> "completed" And LCase(arrdata(i, 5)) Like "*" & tbox & "*" And _
       LCase(arrdata(i, 3)) = cbox Then
      Call add_ToListbox(lngrow, i)
      lngrow = lngrow + 1
    End If
  Next
End Sub

Private Sub UserForm_Initialize()
  Dim lngindex As Long
  Dim lngrow As Long
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
  arrdata = Worksheets("Current").Range("A1").CurrentRegion.Value
 
  With Me.lstHeaders
    .ColumnCount = 7
    .ColumnWidths = "180;60;255;95;75;105;65"
    .Font.Size = 13
    .Font.Bold = True
    .Enabled = False
     .AddItem
    .List(lngrow, 0) = arrdata(1, 3)
    .List(lngrow, 1) = arrdata(1, 4)
    .List(lngrow, 2) = arrdata(1, 5)
    .List(lngrow, 3) = arrdata(1, 10)
    .List(lngrow, 4) = arrdata(1, 11)
    .List(lngrow, 5) = arrdata(1, 13)
    .List(lngrow, 6) = arrdata(1, 14)
  End With
 
  With Me.CarList
    .ColumnCount = 7
    .ColumnWidths = "180;60;255;95;75;105;65"
    .Font.Size = 13
  End With
 
  lngrow = 0
  For lngindex = LBound(arrdata, 1) + 1 To UBound(arrdata, 1)
    If arrdata(lngindex, 13) <> "completed" Then
      Call add_ToListbox(lngrow, lngindex)
     
      If Not dic.exists(arrdata(lngindex, 3)) Then
        dic(arrdata(lngindex, 3)) = Empty
      End If
     
      lngrow = lngrow + 1
    End If
  Next lngindex
 
  ModelCB.List = dic.keys
End Sub

Sub add_ToListbox(lngrow, lngindex)
  With Me.CarList
    .AddItem
    .List(lngrow, 0) = arrdata(lngindex, 3)
    .List(lngrow, 1) = arrdata(lngindex, 4)
    .List(lngrow, 2) = arrdata(lngindex, 5)
    .List(lngrow, 3) = arrdata(lngindex, 10)
    .List(lngrow, 4) = arrdata(lngindex, 11)
    .List(lngrow, 5) = arrdata(lngindex, 13)
    .List(lngrow, 6) = arrdata(lngindex, 14)
    End With
End Sub

Regards
Dante Amor
Click to expand...
hi,

It bring the "permission denied" error
 
Upvote 0
DanteAmor said:
Replace all your code for this, contains the code to load the ModelCB from start.


VBA Code: 
Option Explicit

Dim arrdata() As Variant        'at the beginning of all the code

Private Sub ModelCB_Change()
  Call Filter_Data
End Sub

Private Sub UserFilter_Change()
  Dim dic As Object
  Dim i As Long
 
  Set dic = CreateObject("Scripting.Dictionary")

  Call Filter_Data
 
  For i = 0 To CarList.ListCount - 1
    If Not dic.exists(CarList.List(i, 0)) Then
      dic(CarList.List(i, 0)) = Empty
    End If
  Next
 
  ModelCB.List = dic.keys
End Sub

Sub Filter_Data()
  Dim i As Long, lngrow As Long
  Dim tbox As String, cbox As String

  Me.CarList.Clear
  lngrow = 0
  For i = LBound(arrdata, 1) + 1 To UBound(arrdata, 1)
    If UserFilter.Value = "" Then tbox = LCase(arrdata(i, 5)) Else tbox = LCase(UserFilter.Value)
    If ModelCB.Value = "" Then cbox = LCase(arrdata(i, 3)) Else cbox = LCase(ModelCB.Value)
  
    If arrdata(i, 13) <> "completed" And LCase(arrdata(i, 5)) Like "*" & tbox & "*" And _
       LCase(arrdata(i, 3)) = cbox Then
      Call add_ToListbox(lngrow, i)
      lngrow = lngrow + 1
    End If
  Next
End Sub

Private Sub UserForm_Initialize()
  Dim lngindex As Long
  Dim lngrow As Long
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
  arrdata = Worksheets("Current").Range("A1").CurrentRegion.Value
 
  With Me.lstHeaders
    .ColumnCount = 7
    .ColumnWidths = "180;60;255;95;75;105;65"
    .Font.Size = 13
    .Font.Bold = True
    .Enabled = False
     .AddItem
    .List(lngrow, 0) = arrdata(1, 3)
    .List(lngrow, 1) = arrdata(1, 4)
    .List(lngrow, 2) = arrdata(1, 5)
    .List(lngrow, 3) = arrdata(1, 10)
    .List(lngrow, 4) = arrdata(1, 11)
    .List(lngrow, 5) = arrdata(1, 13)
    .List(lngrow, 6) = arrdata(1, 14)
  End With
 
  With Me.CarList
    .ColumnCount = 7
    .ColumnWidths = "180;60;255;95;75;105;65"
    .Font.Size = 13
  End With
 
  lngrow = 0
  For lngindex = LBound(arrdata, 1) + 1 To UBound(arrdata, 1)
    If arrdata(lngindex, 13) <> "completed" Then
      Call add_ToListbox(lngrow, lngindex)
     
      If Not dic.exists(arrdata(lngindex, 3)) Then
        dic(arrdata(lngindex, 3)) = Empty
      End If
     
      lngrow = lngrow + 1
    End If
  Next lngindex
 
  ModelCB.List = dic.keys
End Sub

Sub add_ToListbox(lngrow, lngindex)
  With Me.CarList
    .AddItem
    .List(lngrow, 0) = arrdata(lngindex, 3)
    .List(lngrow, 1) = arrdata(lngindex, 4)
    .List(lngrow, 2) = arrdata(lngindex, 5)
    .List(lngrow, 3) = arrdata(lngindex, 10)
    .List(lngrow, 4) = arrdata(lngindex, 11)
    .List(lngrow, 5) = arrdata(lngindex, 13)
    .List(lngrow, 6) = arrdata(lngindex, 14)
    End With
End Sub

Regards
Dante Amor
Click to expand...
just fixed thanks!
 
Upvote 0
You must log in or register to reply here.

Similar threads

brendalpzm
  • Locked
  • Question Question
Populate an ActiveX combo box according to a List Box values
Replies
1
Views
418
Fluff
Fluff
brendalpzm
  • Solved
Filter a list based on a text box value
Replies
7
Views
563
DanteAmor
DanteAmor
C
  • Question Question
Searching using TextBox and ListBox
Replies
1
Views
230
campbell1093
C
I
  • Question Question
Filter Status Using Checkbox
Replies
1
Views
202
iggyboy29
I
I
  • Locked
  • Question Question
Auto Filter in Excel
Replies
1
Views
188
Fluff
Fluff

Forum statistics

Threads
1,223,885
Messages
6,175,184
Members
452,615
Latest member
bogeys2birdies

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