Excel VBA Userform to search multiple worksheets

ExcelEndeavor

ExcelEndeavor

New Member
Joined
Oct 13, 2020
Messages
29
Office Version
  1. 365
Platform
  1. MacOS
First, some context...

I have a userform that users complete to capture the salesperson, product ID, product category, revenue amount, and sales date. There is a submit button that funnels the data into 1 of 5 seperate worksheets that are based on product category selected in the userform:

Industrial, consturction, maintenance, hospitality, administrative

(All of the worksheets are formatted exactly the same with the salesperson in column C - it's just to keep the categories separate)

*** This part works great ***



Now, I want to create a userform to search for the salesperson across all 5 worksheets and display the results into a listbox. Then, I can double-click one of the results to open the original userform that was completed for the details of that item and/or make edits if needed. Again, the worksheets are all formatted exactly the same, with the Salesperson in column C.

How would I accomplish this?
 
Sort by date Sort by votes

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
All sheets are empty after row 16 :unsure:

I put some validations in the code for when your sheets do not have information.

Replace the OpenExistingForm code with the following:
VBA Code: 
Option Explicit
Dim a As Variant

Private Sub ComboLookup_Change()
  Call Filter_Data
End Sub

Private Sub TxtKeywords_Change()
  Call Filter_Data
End Sub

Sub Filter_Data()
  Dim i As Long, j As Long, k As Long
  Dim tbox As String, cbox As String, cad As String
  Dim col As Long, n As Long

  'Show no results in lbxResults unless ComboLookup item is selected
  If Me.TxtKeywords.Text = "" Then
    Me.lbxResults.Clear
    Exit Sub
  End If
  
  On Error Resume Next
    n = UBound(a, 1)
    If n = 0 Then
      MsgBox "no data"
      Exit Sub
    End If
  On Error GoTo 0
  
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  For i = 1 To UBound(a, 1)
    If col = 0 Then
      cad = "|" & LCase(a(i, 1)) & "|" & LCase(a(i, 2)) & "|" & LCase(a(i, 3)) & "|" & LCase(a(i, 4)) & "|" & LCase(a(i, 5)) & "|"
    Else
      cad = LCase(a(i, col))
    End If
    
    If TxtKeywords.Value = "" Then tbox = cad Else tbox = LCase(TxtKeywords.Value)
    
    If cad Like "*" & tbox & "*" Then
      k = k + 1
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next
    End If
  Next
  
  Me.lbxResults.List = b
End Sub

Private Sub lbxResults_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Dim shName As String
  Dim nRow As Long
 
  With lbxResults
  
    shName = .List(.ListIndex, .ColumnCount - 2)
    nRow = .List(.ListIndex, .ColumnCount - 1)
    'MsgBox "Sheet : " & shName & vbCr & "Row: " & nRow
    'Unload Me
    
    RequestForm.TxtTeamLead = .List(.ListIndex, 0)
    RequestForm.ComboBU = .List(.ListIndex, 19)
    RequestForm.ComboCategory = .List(.ListIndex, 1)
    RequestForm.ComboSubcategory = .List(.ListIndex, 2)
    
'    RequestForm.TxtExpenseAcct.Enabled = True
'    RequestForm.TxtExpenseAcct = .List(.ListIndex, 3)
'    RequestForm.TxtExpenseAcct.Enabled = False
    
    RequestForm.TxtPayee = .List(.ListIndex, 4)
    RequestForm.TxtDescription = .List(.ListIndex, 5)
    RequestForm.TxtBudget = .List(.ListIndex, 6)
    
    RequestForm.TxtPONbr = .List(.ListIndex, 7)
    RequestForm.TxtInvoice1Nbr = .List(.ListIndex, 8)
    RequestForm.TxtInvoice1Date = .List(.ListIndex, 9)
    RequestForm.TxtInvoice1Amnt = .List(.ListIndex, 10)
    
    RequestForm.TxtInvoice2Nbr = .List(.ListIndex, 11)
    RequestForm.TxtInvoice2Date = .List(.ListIndex, 12)
    RequestForm.TxtInvoice2Amnt = .List(.ListIndex, 13)
    
    RequestForm.TxtInvoice3Nbr = .List(.ListIndex, 14)
    RequestForm.TxtInvoice3Date = .List(.ListIndex, 15)
    RequestForm.TxtInvoice3Amnt = .List(.ListIndex, 16)
    
    RequestForm.TxtInvoiceTotal = .List(.ListIndex, 17)
    
    RequestForm.Label2 = "True"
    RequestForm.ComboBU.Enabled = False
    RequestForm.TxtTeamLead.Enabled = False
    RequestForm.updateRow = .List(.ListIndex, 20)
    
    Unload Me
  End With
End Sub

Private Sub UserForm_Activate()
  Dim b As Variant
  Dim sh As Worksheet
  Dim arr As Variant, itm As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, nMax As Long
  Dim col As String
 
  arr = Array("Enterprise", "MI", "Title", "Real Estate", "Conduit", "Corp Comm", "Events")
  With lbxResults
    col = "S"
    .ColumnCount = Columns(col).Column + 2
    '                A   B   C   D E   F G H   I J K L M N O P Q R S
    .ColumnWidths = "130;130;130;0;130;0;0;100;0;0;0;0;0;0;0;0;0;0;0;80;0"
    .Clear
  End With
  
  With ListBox1
    .ColumnCount = 6
    .ColumnWidths = "130;130;130;130;100;80"
    .Column = Application.Transpose(Array("Team Lead", "Category", "Subcategory", "Payee", "PO Number", "Business Unit"))
  End With
  
  k = 0
  For Each itm In arr
    Set sh = Sheets(itm)
    lr = sh.Range("C" & Rows.Count).End(3).Row
    nMax = nMax + (lr - 16)
  Next
  
  If nMax = 0 Then
    MsgBox "No data"
    Exit Sub
  End If
  
  ReDim a(1 To nMax, 1 To Columns(col).Column + 2)
  For Each itm In arr
    Set sh = Sheets(itm)
    lr = sh.Range("C" & Rows.Count).End(3).Row
    If lr > 16 Then
      b = sh.Range("A17:" & col & lr).Value
      For i = 1 To UBound(b, 1)
        k = k + 1
        For j = 1 To UBound(b, 2)
          a(k, j) = b(i, j)
        Next
        a(k, UBound(a, 2) - 1) = sh.Name
        a(k, UBound(a, 2)) = i + 16
      Next
    End If
  Next
End Sub

Private Sub UserForm_Initialize()
  ComboLookup.List = Array("Team Lead", "Category", "Subcategory", "Payee", "PO Number")
  ComboLookup.SetFocus
End Sub

🫡
 
Upvote 0
Solution
DanteAmor said:
All sheets are empty after row 16 :unsure:

I put some validations in the code for when your sheets do not have information.

Replace the OpenExistingForm code with the following:
VBA Code: 
Option Explicit
Dim a As Variant

Private Sub ComboLookup_Change()
  Call Filter_Data
End Sub

Private Sub TxtKeywords_Change()
  Call Filter_Data
End Sub

Sub Filter_Data()
  Dim i As Long, j As Long, k As Long
  Dim tbox As String, cbox As String, cad As String
  Dim col As Long, n As Long

  'Show no results in lbxResults unless ComboLookup item is selected
  If Me.TxtKeywords.Text = "" Then
    Me.lbxResults.Clear
    Exit Sub
  End If
 
  On Error Resume Next
    n = UBound(a, 1)
    If n = 0 Then
      MsgBox "no data"
      Exit Sub
    End If
  On Error GoTo 0
 
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  For i = 1 To UBound(a, 1)
    If col = 0 Then
      cad = "|" & LCase(a(i, 1)) & "|" & LCase(a(i, 2)) & "|" & LCase(a(i, 3)) & "|" & LCase(a(i, 4)) & "|" & LCase(a(i, 5)) & "|"
    Else
      cad = LCase(a(i, col))
    End If
   
    If TxtKeywords.Value = "" Then tbox = cad Else tbox = LCase(TxtKeywords.Value)
   
    If cad Like "*" & tbox & "*" Then
      k = k + 1
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next
    End If
  Next
 
  Me.lbxResults.List = b
End Sub

Private Sub lbxResults_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Dim shName As String
  Dim nRow As Long
 
  With lbxResults
 
    shName = .List(.ListIndex, .ColumnCount - 2)
    nRow = .List(.ListIndex, .ColumnCount - 1)
    'MsgBox "Sheet : " & shName & vbCr & "Row: " & nRow
    'Unload Me
   
    RequestForm.TxtTeamLead = .List(.ListIndex, 0)
    RequestForm.ComboBU = .List(.ListIndex, 19)
    RequestForm.ComboCategory = .List(.ListIndex, 1)
    RequestForm.ComboSubcategory = .List(.ListIndex, 2)
   
'    RequestForm.TxtExpenseAcct.Enabled = True
'    RequestForm.TxtExpenseAcct = .List(.ListIndex, 3)
'    RequestForm.TxtExpenseAcct.Enabled = False
   
    RequestForm.TxtPayee = .List(.ListIndex, 4)
    RequestForm.TxtDescription = .List(.ListIndex, 5)
    RequestForm.TxtBudget = .List(.ListIndex, 6)
   
    RequestForm.TxtPONbr = .List(.ListIndex, 7)
    RequestForm.TxtInvoice1Nbr = .List(.ListIndex, 8)
    RequestForm.TxtInvoice1Date = .List(.ListIndex, 9)
    RequestForm.TxtInvoice1Amnt = .List(.ListIndex, 10)
   
    RequestForm.TxtInvoice2Nbr = .List(.ListIndex, 11)
    RequestForm.TxtInvoice2Date = .List(.ListIndex, 12)
    RequestForm.TxtInvoice2Amnt = .List(.ListIndex, 13)
   
    RequestForm.TxtInvoice3Nbr = .List(.ListIndex, 14)
    RequestForm.TxtInvoice3Date = .List(.ListIndex, 15)
    RequestForm.TxtInvoice3Amnt = .List(.ListIndex, 16)
   
    RequestForm.TxtInvoiceTotal = .List(.ListIndex, 17)
   
    RequestForm.Label2 = "True"
    RequestForm.ComboBU.Enabled = False
    RequestForm.TxtTeamLead.Enabled = False
    RequestForm.updateRow = .List(.ListIndex, 20)
   
    Unload Me
  End With
End Sub

Private Sub UserForm_Activate()
  Dim b As Variant
  Dim sh As Worksheet
  Dim arr As Variant, itm As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, nMax As Long
  Dim col As String
 
  arr = Array("Enterprise", "MI", "Title", "Real Estate", "Conduit", "Corp Comm", "Events")
  With lbxResults
    col = "S"
    .ColumnCount = Columns(col).Column + 2
    '                A   B   C   D E   F G H   I J K L M N O P Q R S
    .ColumnWidths = "130;130;130;0;130;0;0;100;0;0;0;0;0;0;0;0;0;0;0;80;0"
    .Clear
  End With
 
  With ListBox1
    .ColumnCount = 6
    .ColumnWidths = "130;130;130;130;100;80"
    .Column = Application.Transpose(Array("Team Lead", "Category", "Subcategory", "Payee", "PO Number", "Business Unit"))
  End With
 
  k = 0
  For Each itm In arr
    Set sh = Sheets(itm)
    lr = sh.Range("C" & Rows.Count).End(3).Row
    nMax = nMax + (lr - 16)
  Next
 
  If nMax = 0 Then
    MsgBox "No data"
    Exit Sub
  End If
 
  ReDim a(1 To nMax, 1 To Columns(col).Column + 2)
  For Each itm In arr
    Set sh = Sheets(itm)
    lr = sh.Range("C" & Rows.Count).End(3).Row
    If lr > 16 Then
      b = sh.Range("A17:" & col & lr).Value
      For i = 1 To UBound(b, 1)
        k = k + 1
        For j = 1 To UBound(b, 2)
          a(k, j) = b(i, j)
        Next
        a(k, UBound(a, 2) - 1) = sh.Name
        a(k, UBound(a, 2)) = i + 16
      Next
    End If
  Next
End Sub

Private Sub UserForm_Initialize()
  ComboLookup.List = Array("Team Lead", "Category", "Subcategory", "Payee", "PO Number")
  ComboLookup.SetFocus
End Sub

🫡
Click to expand...

This one is the blank one that I can use to start. I actually had the same error when it was populated. But your code has once again fixed it - you are a miracle worker. Thank you again :)
 
Upvote 0
ExcelEndeavor,

Please Note: In the future, when marking a post as the solution, please mark the post that contains the solution (not your own post acknowledging that some other post was the solution).
When a post is marked as the solution, it is then shown right underneath the original question so people viewing the question can easily see the question and solution in a single quick glance without having to hunt through all the posts.

I have updated this thread for you.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
I have 1 UserForm and want to save to different sheets in the same workbook
2
Replies
10
Views
467
Ellendigitl00
E
S
  • Question Question
Excel VBA - Sort & Get Totals - Logic
Replies
4
Views
550
STARL0RD
S
WERNER SLABBERT
  • Question Question
Run-time error 70 after code changed
Replies
3
Views
201
RoryA
RoryA
M
  • Question Question
search in worksheet for multiple words via userform
Replies
6
Views
499
Max01
M
N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
601
mumps
mumps

Forum statistics

Threads
1,226,528
Messages
6,191,580
Members
453,665
Latest member
WaterWorks

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