Search for specific data and wildcard option

J

josros60

Well-known Member
Joined
Jun 27, 2010
Messages
786
Office Version
  1. 365
Hi,

I found the code below the problem is can only find if type the SAGEID but want to be able to search for other fields listed in the code if possible to search wildcard the SearchForm have five textboxes to search for for example if just want to find JS Analyst when type for that list all of them (attaching picture of the form).

here is the code:

VBA Code: 
Private Sub SearchBtn_Click()

    Dim SearchTerm As String
    Dim SearchColumn As String
    Dim RecordRange As Range
    Dim FirstAddress As String
    Dim FirstCell As Range
    Dim RowCount As Integer
    
    ' Display an error if no search term is entered
    If SAGEID.Value = "" And VENDOR.Value = "" And GL_ACCOUNT.Value = "" And OrgUnit.Value = "" And Analyst.Value = "" Then
    
        MsgBox "No search term specified", vbCritical + vbOKOnly
        Exit Sub
    
    End If
    
    ' Work out what is being searched for
    If SAGEID.Value <> "" Then
    
        SearchTerm = SAGEID.Value
        SearchColumn = "SAGEID"
        
    End If
    
    If VENDOR.Value <> "" Then
    
        SearchTerm = VENDOR.Value
        SearchColumn = "VENDOR"
        
    End If

    If OrgUnit.Value <> "" Then
    
        SearchTerm = GL_ACCOUNT.Value
        SearchColumn = "G/L ACCOUNT"
        
    End If

    If OrgUnit.Value <> "" Then
    
        SearchTerm = OrgUnit.Value
        SearchColumn = "ORG UNIT"
        
        If Analyst.Value <> "" Then
    
        SearchTerm = Analyst.Value
        SearchColumn = "Analyst"
        
    End If
    
    End If
    Results.Clear
    
        ' Only search in the relevant table column i.e. if somone is searching Location
        ' only search in the Location column
        With Range("Table1[" & SearchColumn & "]")
        
        ' Find the first match
            Set RecordRange = .Find(SearchTerm, LookIn:=xlValues)

            ' If a match has been found
            If Not RecordRange Is Nothing Then

                FirstAddress = RecordRange.Address
                RowCount = 0

                Do
                
                    ' Set the first cell in the row of the matching value
                    Set FirstCell = Range("A" & RecordRange.Row)
                    
                    ' Add matching record to List Box
                    Results.AddItem
                    Results.List(RowCount, 0) = FirstCell(1, 1)
                    Results.List(RowCount, 1) = FirstCell(1, 2)
                    Results.List(RowCount, 2) = FirstCell(1, 3)
                    Results.List(RowCount, 3) = FirstCell(1, 4)
                    Results.List(RowCount, 4) = FirstCell(1, 5)
                    Results.List(RowCount, 5) = FirstCell(1, 6)
                    Results.List(RowCount, 6) = FirstCell(1, 7)
                    Results.List(RowCount, 7) = FirstCell(1, 8)
                    Results.List(RowCount, 8) = FirstCell(1, 9)
                    RowCount = RowCount + 1
                    
                    ' Look for next match
                    Set RecordRange = .FindNext(RecordRange)

                    ' When no further matches are found, exit the sub
                    If RecordRange Is Nothing Then

                        Exit Sub

                    End If

                ' Keep looking while unique matches are found
                Loop While RecordRange.Address <> FirstAddress

            Else
            
                ' If you get here, no matches were found
                Results.AddItem
                Results.List(RowCount, 0) = "Nothing Found"
            
            End If
          
            

        End With

End Sub

Thank you,
 

Attachments

  • SEARCHFORM.PNG
    SEARCHFORM.PNG
    40.2 KB · Views: 20

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
just for the fun, i did this in a dictionary, but if you like you can filter your listbox in the 5 columns and copy the remaining listrows to your listbox or combobox.
The part between asterixes was for my test, i didn't have textboxes, so i used ranges.

VBA Code: 
Option Compare Text                                             'IMPORTANT !!!!! makes the whole module not case-sensitive

Sub SearchBtn_Click()

     '************************************************
     ' this is for me, testing with ranges instead of textboxes
     Set sageid = Range("sageid")
     Set vendor = Range("vendor")
     Set gl_account = Range("gl_account")
     Set OrgUnit = Range("OrgUnit")
     Set Analyst = Range("Analyst")
     '*************************************************

     Dim sh, LO, DBR, HRR, C As Range, MyResults, Arr()
     Set dict = CreateObject("scripting.dictionary")            'dictionary for the result
     Set C = Range("Table1")                                    '
     Set LO = C.ListObject                                      'your listobject
     DBR = LO.DataBodyRange.Value                               'read the databodyrange
     HRR = LO.HeaderRowRange.Value                              'read the headerrow
     dict.Add dict.Count, HRR                                   '1st item in dictionary

     'prepare an array for filtering
     ReDim Arr(1 To 5, 1 To 3)                                  '5 terms
     If sageid.Value <> "" Then Arr(1, 2) = sageid.Value: Arr(1, 1) = "SAGEID"
     If vendor.Value <> "" Then Arr(2, 2) = vendor.Value: Arr(2, 1) = "VENDOR"
     If OrgUnit.Value <> "" Then Arr(3, 2) = gl_account.Value: Arr(3, 1) = "G/L ACCOUNT"
     If OrgUnit.Value <> "" Then Arr(4, 2) = OrgUnit.Value: Arr(4, 1) = "ORG UNIT"
     If Analyst.Value <> "" Then Arr(5, 2) = Analyst.Value: Arr(5, 1) = "Analyst"
     For i = 1 To UBound(Arr)
          On Error Resume Next
          Set c1 = Nothing: Set c1 = LO.ListColumns(Arr(i, 1)).Range     'find corresponding listcolumn and columnnumber
          On Error GoTo 0
          If c1 Is Nothing Then
               MsgBox "no column " & Arr(i, 1)
          Else
               If Len(Arr(i, 1)) > 0 Then Arr(i, 3) = LO.ListColumns(Arr(i, 1)).Range.Column - LO.Range.Column + 1
          End If
     Next

     'loop through data and if okay add to dictionary
     For r = 1 To UBound(DBR)                                   'loop through all data
          bflag = True
          For i = 1 To UBound(Arr)                              'loop through all filters
               If Arr(i, 3) > 0 Then bflag = (DBR(r, Arr(i, 3)) = Arr(i, 2))     'check if element in that column is okay
               If bflag = False Then Exit For                   'if flag no more okay then stop loop
          Next
          If bflag Then dict.Add dict.Count, Application.Index(DBR, r, 0)     'if flag still okay, add to dictionary
     Next

     'dictionary -> combobox or listbox
     MyResults = Application.Index(dict.items, 0, 0)            'read the dictionary
     Select Case dict.Count
          Case 1: MsgBox "nothing left"
          Case Else:
               MsgBox "caution, writing to cell AB1", vbCritical
               Range("AB1").Resize(UBound(MyResults), UBound(MyResults, 2)).Value = MyResults     'this is my line not yours
     'result.List = MyResults'here starts your job, take the whole array execpt for the 1e row
               MsgBox "delete first entry"
     End Select

End Sub
 
Upvote 0
Hi,

I tried but giving this error Variable no defined and highlight this line:


VBA Code: 
 Set dict = CreateObject("scripting.dictionary")

Thank you,
 
Upvote 0
add dict to this line and next perhaps also i, c1 and others (i don't use "option explicit")
VBA Code: 
Dim sh, LO, DBR, HRR, C As Range, MyResults, Arr(),dict
 
Upvote 0
I changed the line as your suggestion:
VBA Code: 
Dim sh, LO, DBR, HRR, C As Range, MyResults, Arr(), dict, i, c1

But now giving variable no defined again and highlight this line:

VBA Code: 
For r = 1 To UBound(DBR)

thank you
 
Upvote 0
add r in that dim row or delete "option explicit" (i'm not a big fan of that)
 
Upvote 0
Now keep displaying no column few times and then nothing left.

This the code now:

VBA Code: 
Private Sub SearchBtn_Click()
Dim sh, LO, DBR, HRR, C As Range, MyResults, Arr(), dict, i, r
     Set dict = CreateObject("scripting.dictionary")            'dictionary for the result
     Set C = Range("Table1")                                    '
     Set LO = C.ListObject                                      'your listobject
     DBR = LO.DataBodyRange.Value                               'read the databodyrange
     HRR = LO.HeaderRowRange.Value                              'read the headerrow
     dict.Add dict.Count, HRR                                   '1st item in dictionary

     'prepare an array for filtering
     ReDim Arr(1 To 5, 1 To 3)                                  '5 terms
     If SAGEID.Value <> "" Then Arr(1, 2) = SAGEID.Value: Arr(1, 1) = "SAGEID"
     If VENDOR.Value <> "" Then Arr(2, 2) = VENDOR.Value: Arr(2, 1) = "VENDOR"
     If OrgUnit.Value <> "" Then Arr(3, 2) = GL_ACCOUNT.Value: Arr(3, 1) = "G/L ACCOUNT"
     If OrgUnit.Value <> "" Then Arr(4, 2) = OrgUnit.Value: Arr(4, 1) = "ORG UNIT"
     If Analyst.Value <> "" Then Arr(5, 2) = Analyst.Value: Arr(5, 1) = "Analyst"
     For i = 1 To UBound(Arr)
          On Error Resume Next
          Set C1 = Nothing: Set C1 = LO.ListColumns(Arr(i, 1)).Range     'find corresponding listcolumn and columnnumber
          On Error GoTo 0
          If C1 Is Nothing Then
               MsgBox "no column " & Arr(i, 1)
          Else
               If Len(Arr(i, 1)) > 0 Then Arr(i, 3) = LO.ListColumns(Arr(i, 1)).Range.Column - LO.Range.Column + 1
          End If
     Next

     'loop through data and if okay add to dictionary
     For r = 1 To UBound(DBR)                                   'loop through all data
          bflag = True
          For i = 1 To UBound(Arr)                              'loop through all filters
               If Arr(i, 3) > 0 Then bflag = (DBR(r, Arr(i, 3)) = Arr(i, 2))     'check if element in that column is okay
               If bflag = False Then Exit For                   'if flag no more okay then stop loop
          Next
          If bflag Then dict.Add dict.Count, Application.Index(DBR, r, 0)     'if flag still okay, add to dictionary
     Next

     'dictionary -> combobox or listbox
     MyResults = Application.Index(dict.items, 0, 0)            'read the dictionary
     Select Case dict.Count
          Case 1: MsgBox "nothing left"
          Case Else:
               MsgBox "caution, writing to cell AB1", vbCritical
               Range("AB1").Resize(UBound(MyResults), UBound(MyResults, 2)).Value = MyResults     'this is my line not yours
     'result.List = MyResults'here starts your job, take the whole array execpt for the 1e row
               MsgBox "delete first entry"
     End Select
    

End Sub
 
Upvote 0
Here:

NAVIGATA_DISTRIBUTION SETS-CODES.xlsm
ABCDEFGH
2SAGEIDVENDORACCOUNT #LINE DESCRIPTIONG/L ACCOUNTG/L DESCRIPTIONORG UNITANALYST
3100215ABC COMM.17786-28380,28620, 30862Fixed Data-Customer-Data Services-17786-602110-28-500-100Fixed Data - Customer - Data Services: C - TCOM - ONTNavigata - Carrier CostingMJT
4100109AFX COMMUNICATIONS80017LD - TOLL FREE OTHER SERVICES603202-28-500-100LD - TF - Other : C - TCOM - ONNavigata - Carrier CostingMJT
5100176AIRESPRING1352791LD - Toll DAL : C - TCOM - BC603220-28-500-100LD - Toll DAL : C - TCOM - ONNavigata - Carrier CostingMJT
6100072ANI NETWORKS100226-1001LD - Toll DAL : C - TCOM - BC603220-28-500-100LD - Toll DAL : C - TCOM - ONNavigata - Carrier CostingMJT
7100226ARIN100226LEGACY ANNUAL MAINTENANCE601420-28-500-100Internet - Other - General Internet Transit : C - TCOM - ONNavigata - Carrier CostingJM
8100125AT&T 831831-000-5480-119,264,269Local&VOIP - Other - Services605130-28-500-100Local&VOIP - Other : C - TCOM - ONNavigata - Carrier CostingMJT
9100068BELL TOLL FREECB001945LD - TOLL FREE OTHER SERVICES603202-28-500-100LD - TF - Other : C - TCOM - ONNavigata - Carrier CostingMJT
10100356CCTS(COMMISSION FOR COMPLAINTS FOR TELECOM)611100-28-500-100Local&VOIP - Regulatory Charges C - TCOM - ONNavigata - Carrier CostingMJT
11100120CITY OF NELSON8048HALF RACK COLOCATION RENTAL PER MJTREEMENT601432-28-500-100Network Sites Utilities: C - TCOM - ONNavigata - Carrier CostingMJT
12100313CLOUD (CTI)63015EMBEDDED INTEGRATION/ADMIN FEES-760050-28-550-100Software Licences C - NSE ONNavigata - Carrier CostingMJT
13100271COMWAVEL00004Local&VOIP - Other - Services605130-28-500-10Local&VOIP - Other : C - TCOM - ONNavigata - Carrier CostingMJT
14100116COUNTRY COMM.100116LD - Toll DAL : C - TCOM - BC603220-28-500-100LD - Toll DAL : C - TCOM - ONNavigata - Carrier CostingMJT
15100116COUNTRY COMM.100116Contra to OFFSET A/R-A/P Balances-131100-08-000-500Accounts Receivable - Customer Billing: G - G - BCNavigata - COGs approvedJM
16100123DMTS193526LD - TF - CABS - FGC : C - TCOM - ON603200-28-500-100LD - TF - CABS - FGC : C - TCOM - ONNavigata - Carrier CostingMJT
17100023ENTERMARK DISTRIBUTION INC.136333LD - Toll DAL : C - TCOM - BC603220-28-500-100LD Toll DAL C -TCOM - ONNavigata - Carrier CostingMJT
18100066EsTRUXTURE4526Iinternet Sevices601420-28-500-100Internet - Other - General Internet Transit : C - TCOM - ONNavigata - Carrier CostingMJT
DIST CODE
Cell Formulas
RangeFormula
G6,G18,G12:G14,G8:G10G6=VLOOKUP([@SAGEID],Table2,5)
C9,C14C9=VLOOKUP([@SAGEID],Table2[[SAGE ID ]:[Org Unit ]],3)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A3:H52,A53:E53,G53:H53Expression=COLUMN()=CELL("col")textNO
A3:H52,A53:E53,G53:H53Expression=CELL("row")=ROW()textNO


thank you,
 
Upvote 0
VBA Code: 
Option Compare Text                                             'IMPORTANT !!!!! makes the whole module not case-sensitive
Option Explicit

Sub SearchBtn_Click()
     Dim SageID, Vendor, GL_Account, OrgUnit, Analyst
     '************************************************
     ' this is for me, testing with ranges instead of textboxes
     Set SageID = Range("sageid")
     Set Vendor = Range("vendor")
     Set GL_Account = Range("gl_account")
     Set OrgUnit = Range("OrgUnit")
     Set Analyst = Range("Analyst")
     '*************************************************

     Dim sh, LO, DBR, HRR, C As Range, c1, MyResults, Arr(), Dict, r, bFlag, i
     Set Dict = CreateObject("scripting.dictionary")            'dictionary for the result
     Set C = Range("Table1")                                    '
     Set LO = C.ListObject                                      'your listobject
     DBR = LO.DataBodyRange.Value                               'read the databodyrange
     HRR = LO.HeaderRowRange.Value                              'read the headerrow
     Dict.Add Dict.Count, HRR                                   '1st item in dictionary=headerrow, 'll be deleted immediately when assigning combobox

     'prepare an array for filtering
     ReDim Arr(1 To 5, 1 To 3)                                  '5 terms
     If SageID.Value <> "" Then Arr(1, 2) = SageID.Value: Arr(1, 1) = "SAGEID"
     If Vendor.Value <> "" Then Arr(2, 2) = Vendor.Value: Arr(2, 1) = "VENDOR"
     If OrgUnit.Value <> "" Then Arr(3, 2) = GL_Account.Value: Arr(3, 1) = "G/L ACCOUNT"
     If OrgUnit.Value <> "" Then Arr(4, 2) = OrgUnit.Value: Arr(4, 1) = "ORG UNIT"
     If Analyst.Value <> "" Then Arr(5, 2) = Analyst.Value: Arr(5, 1) = "Analyst"
     For i = 1 To UBound(Arr)
          On Error Resume Next
          Set c1 = Nothing: Set c1 = LO.ListColumns(Arr(i, 1)).Range     'find corresponding listcolumn and columnnumber
          On Error GoTo 0
          If c1 Is Nothing Then
               MsgBox "no column " & Arr(i, 1)
          Else
               If Len(Arr(i, 1)) > 0 Then Arr(i, 3) = LO.ListColumns(Arr(i, 1)).Range.Column - LO.Range.Column + 1
          End If
     Next

     'loop through data and if okay add to dictionary
     For r = 1 To UBound(DBR)                                   'loop through all data
          bFlag = True
          For i = 1 To UBound(Arr)                              'loop through all filters
               If Arr(i, 3) > 0 Then bFlag = (DBR(r, Arr(i, 3)) = Arr(i, 2))     'check if element in that column is okay
               If bFlag = False Then Exit For                   'if flag no more okay then stop loop
          Next
          If bFlag Then
               Dict.Add Dict.Count, Application.Index(DBR, r, 0)     'if flag still okay, add to dictionary
          End If
     Next

     'dictionary -> combobox or listbox
     MyResults = Application.Index(Dict.items, 0, 0)            'read the dictionary
     With Blad2.ComboBox1
          .Clear
          Select Case Dict.Count
               Case 1: MsgBox "nothing left"                    'just the headerrow, so there is no data
               Case Else:
                    .List = MyResults
                    .RemoveItem 0                               'remove headerrrow
          End Select
          .DropDown
     End With
End Sub
josros example
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
ListBox does not display the record I try to find
Replies
9
Views
741
Magic Polygon
M
M
  • Solved
run-time error '9' subscript out of range
Replies
1
Views
630
NdNoviceHlp
NdNoviceHlp
Young Grasshopper
  • Locked
  • Question Question
VBA Form / Search with two criterias
Replies
1
Views
421
Fluff
Fluff
Young Grasshopper
  • Solved
VBA Form / Search with two criterias
2
Replies
14
Views
1K
dmt32
D
T
  • Solved
Search Function: Table vs Array with results showing in Listbox
Replies
5
Views
787
Fluff
Fluff

Forum statistics

Threads
1,224,827
Messages
6,181,200
Members
453,022
Latest member
RobertV1609

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