Excel VBA Userform to search multiple worksheets

[ExcelEndeavor]

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?

 

[ExcelEndeavor]

I can't download that file.
Check the link and put it back here.

Here is the direct link:

Dropbox

www.dropbox.com

 

[DanteAmor]

All sheets are empty after row 16

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

Replace the OpenExistingForm code with the following:

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

 

[ExcelEndeavor]

All sheets are empty after row 16

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

Replace the OpenExistingForm code with the following:

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

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

 

[Joe4]

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.