modifying codes on userform to expand search by two comboboxes and textbox

[Mussa]

Hello
Currently, the code is fetching data based on selecting a specific sheet from combobox1 , and selecting a specific month from combobox2 , it filters the data in the list box based on the sheet selected from combobox1 and the month selected from combobox2 . What I want is when I search for the ID into textbox1 based on the fourth column(D) based on the sheet selected from combobox1 and the month chosen from combobox2 , then the data will be filtered In the list box for that identifier within the selected sheet and month(based on two comboboxes and textbox1)
here is my file
SSR v0 a modified v0 b.xlsm
hope somebody can modify it .

 

[sijpie]

If i see it correctly, it does filter on the ID, but disregards the month. Is that correct?

 

[Mussa]

yes that's correct and this is what I look for it to make searching contains multiple choices .
tthanks

 

[Mussa]

doesn't seem to be possible for modifying !

 

[sijpie]

I am working on it. But in doing so i fond a few inefficiencies in your code. So I am reworking your code (with plenty comments). Then it will be easy to add one or more filters.

 

[sijpie]

Hi Mussa,

I will post the code in two blocks. The first is where I have commented on your code, so it contains a lot of comments. In the second post I will post the clean code, with just some comments .

Please notice that for clarity I have given the comboboxes, textbox and listbox names. So before you run the code you will need to rename these controls in your form. Click on a control. In the left bottom properties panel yo will see the properties of the control. The first property is the name. You can change it there and use the control names I have used.

The way I have changed the code is that the array Arr is filled with the entire database on the selected sheet.
Then there is only one sub to fill the listbox. It runs through the array and filters on date if applicable and loads the data from there. The array data does not get changed.
For the searchfilter : after loading the data (filtered on date or not) into the listbox, the lines not conforming to the search are removed from the listbox.

Working from the array is quicker that reading from the sheet each time.

Enjoy

 

[sijpie]

Here is the code with all comments. Anybody else reading this, the code in the next post only contains relevant comments and so is easier to follow. Ignore the code here.

Option Explicit

Dim myFormat(1) As String
Dim Arr As Variant
'Public Arr As Variant  '// Only declare something public if it is used in more modules or forms. _
 // Even then don't declare it public in a form, as the form needs to be created if it is used in another module. _
 // So publics are declared in a standard module.

Private Sub cbxShtName_Change()
  Dim dicDates As Object
  Dim lR As Long, UB1 As Long
  
  With cbxShtName
    ' combined tests for Exit
    If .Value = "" Or .ListIndex = -1 Then Exit Sub
    With Sheets(.Value).Cells(1).CurrentRegion
'        Set rng = .Offset(1).Resize(.Rows.Count - 1)   'leave out the step with the range. Just set the Arr array to the range
        Arr = .Value
        ' Arr now contains the complete data set for this sheet
'        Arr = .Cells(1).CurrentRegion '.Value
    End With
    'get number of rows in array
    UB1 = UBound(Arr, 1)
    
    'Clear cbxDate
    With cbxDate
        .Clear
        .Value = ""
    End With
    
    '// uncomment next line to clear the search box every time the sheet gets changed
'    tbxSearch = "" 'added- clear search box and CB2
    
    ' Clear the ListBox and repopulate
    ListboxResultPopulate
    
    ' get ready to populate CB2
'    Dim SH As Worksheet, dic As Object, i As Long
'    Set SH = Worksheets(cbxShtName.Value)
    Set dicDates = CreateObject("Scripting.Dictionary")
    ' populate CB2
'    With SH
'      For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
'        dic(Format(CDate(.Range("A" & i).Value), "mmm-yyyy")) = Empty
'      Next i
'    End With
    For lR = 2 To UB1
        dicDates(Format(CDate(Arr(lR, 1)), "mmm-yyyy")) = Empty
    Next lR
    cbxDate.List = dicDates.Keys
    End With
End Sub

Private Sub ListboxResultPopulate()
    Dim lR As Long, lC As Long, UB1 As Long, UB2 As Long, n As Long
    Dim bDt As Boolean, bSrch As Boolean
    Dim sFilter As String
    
    bDt = Len(cbxDate.Value)
    bSrch = Len(tbxSearch.Value)
    
    UB1 = UBound(Arr, 1)
    UB2 = UBound(Arr, 2)
    
    ' Clear the ListBox and repopulate using Arr and the date & search filters
    With Me.lbxResult
        If .ListCount > 0 Then
            .RowSource = ""
            .Clear
        End If
        
        If bDt Then sFilter = cbxDate.Value 'a little bit more efficient within loops
        'now add rows depending on date filter (code based on your FilterByDate sub)
        For lR = 2 To UB1
            If bDt Then
                If Format(CDate(Arr(lR, 1)), "mmm-yyyy") Like sFilter Then
                    AddLine n, lR
                    n = n + 1
               End If
            Else
                AddLine n, lR
'                .AddItem
'                For lC = 1 To UB2
'                    .List(n, lC - 1) = Arr(lR, lC)
'                Next lC
'                .List(n, 0) = Format(CDate(Arr(lR, 1)), "dd/mm/yyyy")
'                .List(n, 7) = Format$(.List(n, 7), myFormat(0))
'                .List(n, 8) = Format$(.List(n, 8), myFormat(1))
'                .List(n, 9) = Format$(.List(n, 9), myFormat(1))
                n = n + 1
            End If
        Next lR
        
        'Next check for Search and remove rows from Listbox
        If bSrch Then
            sFilter = tbxSearch
            ' remove items backwards!!
            For n = .ListCount - 1 To 0 Step -1
                If Not (.List(n, 3) Like "*" & sFilter & "*") Then
                    .RemoveItem (n)
                End If
            Next n
        End If
        
    End With
'//old code
'    lbxResult.RowSource = ""
'    lbxResult.Clear
'    lbxResult.RowSource = "'" & Sheets(.Value).Name & "'!" & Sheets(.Value).Range("A1", Sheets(.Value).Range("H" & Rows.Count).End(3)).Address
'    tbxSearch = "" 'added- clear search box and CB2
'    cbxDate.Value = ""
'  ' rewrite array
'  Arr = lbxResult.List
'//

End Sub

Private Sub AddLine(lIndex As Long, lR As Long)
    Dim UB2 As Long, lC As Long
    
    UB2 = UBound(Arr, 2)

    With lbxResult
        .AddItem
        For lC = 1 To UB2
            .List(lIndex, lC - 1) = Arr(lR, lC)
            '// avoid as much as possible within loops. The following can be done outside the inner loop
'                        ' overwrite the date if appropriate
'                        If ii = 0 Then .List(lIndex, 0) = Format(CDate(Arr(i, 0)), "dd/mm/yyyy")
        Next lC
        .List(lIndex, 0) = Format(CDate(Arr(lR, 1)), "dd/mm/yyyy")
        .List(lIndex, 7) = Format$(.List(lIndex, 7), myFormat(0))
        .List(lIndex, 8) = Format$(.List(lIndex, 8), myFormat(1))
        .List(lIndex, 9) = Format$(.List(lIndex, 9), myFormat(1))
    End With
End Sub


Private Sub cbxDate_Change()

'    If cbxDate.Value = "" Then Exit Sub

    If cbxDate.ListIndex = -1 Then Exit Sub
    
    ListboxResultPopulate
    
'    ' clear text search
'    tbxSearch.Value = ""
'
'    With lbxResult
'        .RowSource = ""
'        .Clear
'        .RowSource = "'" & Sheets(cbxShtName.Value).Name & "'!" & Sheets(cbxShtName.Value).Range("A1", Sheets(cbxShtName.Value).Range("H" & Rows.Count).End(3)).Address
'        Arr = .List
'    End With
'    FilterByDate
End Sub





Private Sub tbxSearch_Change()
    ListboxResultPopulate
'  Call FilterData
End Sub



Private Sub UserForm_Initialize()
'//  in the Initialize sub only set up the form. Don't start filling ot controls. Do that in the Activate sub
    Dim rngDB As Range, rng As Range
    Dim sWidth As String
    Dim vR() As Variant
    Dim n As Integer
    Dim myMax As Single
    
    Dim SH As Worksheet
    ' populate cbxShtName list eith sheet names
    For Each SH In ThisWorkbook.Worksheets
        cbxShtName.AddItem SH.Name
    Next SH
    
    
    Set rngDB = Range("A1:J20")
    For Each rng In rngDB
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = rng.EntireColumn.Width
    Next rng
'// uncomment next lines to have listbox display each column at max width. _
    With it commented out, the width will be the same as on the sheet
'    myMax = WorksheetFunction.Max(vR)
'    For i = 1 To n
'        vR(i) = myMax
'    Next i
'//
    With Sheets("purchase").Cells(1).CurrentRegion
        myFormat(0) = .Cells(2, 8).NumberFormatLocal
        myFormat(1) = .Cells(2, 9).NumberFormatLocal
        'the following will be done in the cbxShtName_Change sub
'        Set rng = .Offset(1).Resize(.Rows.Count - 1)
'        Arr = .Cells(1).CurrentRegion '.Value
    End With

    sWidth = Join(vR, ";")
    'Debug.Print sWidth
    With lbxResult
        .ColumnCount = 10
        .ColumnWidths = sWidth '<~~ 63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63;63
'''''        .List = Arr 'rng.Value
        .BorderStyle = fmBorderStyleSingle
'''''        For lindex = 0 To .ListCount - 1
'''''            .List(lindex, 0) = (Format((.List(lindex, 0)), "dd/mm/yyyy"))   ' BL = dates
'''''                      '  .List(lindex, 0) = lindex + 1
'''''
'''''            .List(lindex, 7) = Format$(.List(lindex, 7), myFormat(0))
'''''            .List(lindex, 8) = Format$(.List(lindex, 8), myFormat(1))
'''''            .List(lindex, 9) = Format$(.List(lindex, 9), myFormat(1))
'''''        Next
       
'        Arr = .List
        '<--- this line
    End With
End Sub
Private Sub UserForm_Activate()
'// No need toduplicate the combobox fill code. Just set the listindex to the first item, then the change code will run \\
    cbxShtName.ListIndex = 0
    
'Dim i As Long, dic As Object
'  Dim SH As Worksheet
'  Set SH = sheet1
'  Set dic = CreateObject("Scripting.Dictionary")
'
'  For i = 2 To SH.Range("A" & Rows.Count).End(xlUp).Row
'    dic(Format(CDate(SH.Range("A" & i).Value), "mmm-yyyy")) = Empty
'  Next
'  cbxDate.List = dic.Keys
'  ' set cbxShtName to the matching value
'  cbxShtName.Value = SH.Name
    
    'set the first sheet in the controlbox. This will call the _
     cbxShtName_Change sub, where the array Arr will be filled
End Sub


'Sub FilterData()
'
'    Dim i As Long, ii As Long, n As Long
'    'Me.lbxResult.List = Arr
'    If Me.tbxSearch = "" Then Exit Sub
'    With Me.lbxResult
'        If .ListCount > 0 Then ' ## added
'            .RowSource = "" ' ## added
'            .Clear
'        End If
'        For i = 0 To UBound(Arr, 1)
'            If UCase$(Arr(i, 3)) Like "*" & UCase$(Me.tbxSearch) & "*" Then ' ## changed
'                .AddItem
'                .List(n, 0) = n + 1
'                For ii = 1 To UBound(Arr, 2)
'                    .List(n, ii) = Arr(i, ii)
'                Next
'                n = n + 1
'            End If
'        Next
'    End With
'End Sub
'Sub FilterByDate() '// now included in ListboxResultPopulate()
'    Dim i As Long, ii As Long, n As Long
'
'    If Me.cbxDate = "" Then
'        UserForm_Activate
'        Exit Sub
'    End If
'    With Me.lbxResult
'
'        If .ListCount > 0 Then
'            .RowSource = ""
'            .Clear
'        End If
'
'
'        ' filter data
'        For i = 1 To UBound(Arr, 1)
'        ' filter array by chosen date
'            If Format(CDate(Arr(i, 0)), "mmm-yyyy") = Me.cbxDate.Value Then
'                .AddItem
'                For ii = 0 To UBound(Arr, 2)
'                    .List(n, ii) = Arr(i, ii)
'                    ' overwrite the date if appropriate
'                    If ii = 0 Then .List(n, 0) = Format(CDate(Arr(i, 0)), "dd/mm/yyyy")
'                Next ii
'                n = n + 1
'            End If
'        Next
'    End With
'End Sub

 

[sijpie]

Here is the clean code and a screenshot of the form.

Option Explicit

Dim myFormat(1) As String
Dim Arr As Variant

Private Sub cbxShtName_Change()
  Dim dicDates As Object
  Dim lR As Long, UB1 As Long
  
  With cbxShtName
    ' combined tests for Exit
    If .Value = "" Or .ListIndex = -1 Then Exit Sub
    With Sheets(.Value).Cells(1).CurrentRegion
        Arr = .Value
        ' Arr now contains the complete data set for this sheet
    End With
    'get number of rows in array
    UB1 = UBound(Arr, 1)
    
    'Clear cbxDate
    With cbxDate
        .Clear
        .Value = ""
    End With
    
    '// uncomment next line to clear the search box every time the sheet gets changed
'    tbxSearch = "" 'added- clear search box and CB2
    
    ' Clear the ListBox and repopulate
    ListboxResultPopulate
    
    Set dicDates = CreateObject("Scripting.Dictionary")
    For lR = 2 To UB1
        dicDates(Format(CDate(Arr(lR, 1)), "mmm-yyyy")) = Empty
    Next lR
    cbxDate.List = dicDates.Keys
    End With
End Sub

Private Sub ListboxResultPopulate()
    Dim lR As Long, lC As Long, UB1 As Long, UB2 As Long, n As Long
    Dim bDt As Boolean, bSrch As Boolean
    Dim sFilter As String
    
    bDt = Len(cbxDate.Value)
    bSrch = Len(tbxSearch.Value)
    
    UB1 = UBound(Arr, 1)
    UB2 = UBound(Arr, 2)
    
    ' Clear the ListBox and repopulate using Arr and the date & search filters
    With Me.lbxResult
        If .ListCount > 0 Then
            .RowSource = ""
            .Clear
        End If
        
        If bDt Then sFilter = cbxDate.Value 'a little bit more efficient within loops
        'now add rows depending on date filter (code based on your FilterByDate sub)
        For lR = 2 To UB1
            If bDt Then
                If Format(CDate(Arr(lR, 1)), "mmm-yyyy") Like sFilter Then
                    AddLine n, lR
                    n = n + 1
               End If
            Else
                AddLine n, lR
                n = n + 1
            End If
        Next lR
        
        'Next check for Search and remove rows from Listbox
        If bSrch Then
            sFilter = tbxSearch
            ' remove items backwards!!
            For n = .ListCount - 1 To 0 Step -1
                If Not (.List(n, 3) Like "*" & sFilter & "*") Then
                    .RemoveItem (n)
                End If
            Next n
        End If
        
    End With

End Sub

Private Sub AddLine(lIndex As Long, lR As Long)
    Dim UB2 As Long, lC As Long
    
    UB2 = UBound(Arr, 2)

    With lbxResult
        .AddItem
        For lC = 1 To UB2
            .List(lIndex, lC - 1) = Arr(lR, lC)
        Next lC
        .List(lIndex, 0) = Format(CDate(Arr(lR, 1)), "dd/mm/yyyy")
        .List(lIndex, 7) = Format$(.List(lIndex, 7), myFormat(0))
        .List(lIndex, 8) = Format$(.List(lIndex, 8), myFormat(1))
        .List(lIndex, 9) = Format$(.List(lIndex, 9), myFormat(1))
    End With
End Sub


Private Sub cbxDate_Change()

    If cbxDate.ListIndex = -1 Then Exit Sub
    
    ListboxResultPopulate
    
End Sub


Private Sub tbxSearch_Change()
    ListboxResultPopulate
End Sub



Private Sub UserForm_Initialize()
'//  in the Initialize sub only set up the form. Don't start filling ot controls. Do that in the Activate sub
    Dim rngDB As Range, rng As Range
    Dim sWidth As String
    Dim vR() As Variant
    Dim n As Integer
    Dim myMax As Single
    
    Dim SH As Worksheet
    ' populate cbxShtName list eith sheet names
    For Each SH In ThisWorkbook.Worksheets
        cbxShtName.AddItem SH.Name
    Next SH
    
    
    Set rngDB = Range("A1:J20")
    For Each rng In rngDB
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = rng.EntireColumn.Width
    Next rng
'// uncomment next lines to have listbox display each column at max width. _
    With it commented out, the width will be the same as on the sheet
'    myMax = WorksheetFunction.Max(vR)
'    For i = 1 To n
'        vR(i) = myMax
'    Next i
'//
    With Sheets("purchase").Cells(1).CurrentRegion
        myFormat(0) = .Cells(2, 8).NumberFormatLocal
        myFormat(1) = .Cells(2, 9).NumberFormatLocal
    End With

    sWidth = Join(vR, ";")
    'Debug.Print sWidth
    With lbxResult
        .ColumnCount = 10
        .ColumnWidths = sWidth
        .BorderStyle = fmBorderStyleSingle

    End With
End Sub

Private Sub UserForm_Activate()
'Set the listindex to the first item, then the change code will run filling the listbox
    cbxShtName.ListIndex = 0
    

End Sub

 

[sijpie]

Name of the
combobox for sheet names: cbxShtName
combobox for date filter: cbxDate
textbox for search: tbxSearch
listbox for results: lbxResult

 

[Mussa]

Awesome buddy!
just I ask about this line

    Set rngDB = Range("A1:J20")

could be dynamic without specify the end of row number,please?