Struggling with a Macro to check entire workbook (all sheets) for rows containing any cell containing a value, and displaying the row in a userform

[NinetalesOCE]

Hi everyone. I'm new here so apologies for the title.

Essentially i have workbook with 6 different worksheets, and i'm trying to make a Macro that allows you to open up a Userform that gives you the option to search the whole workbook.

If the value you search for is included in a cell anywhere, then it will take the entire row that it is in and display it in the userform in a list - and repeat until there is no more cells to check.

I've gone through a bunch of different videos/guides, but I can only seem to check it by column and can't work out how to check the entire worksheet/workbook.

I have attached a picture of what the userform looks like for better understanding.

If anyone has any ideas of how to make it work, that would be extremely appreciated!

 

[DanteAmor]

Hi and welcome to MrExcel.

Try this. Change Textbox1 and Listbox1 by the names of your controls

Private Sub CommandButton1_Click()
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim r As Range, f As Range, cell As String
  Dim sh As Worksheet
  Dim dic As Object
  Dim b As Variant
  
  If TextBox1.Value = "" Then
    MsgBox "Enter value in textbox1"
    TextBox1.SetFocus
  End If
  For Each sh In Sheets
    lr = sh.Cells.SpecialCells(xlCellTypeLastCell).Row
    lc = sh.Cells.SpecialCells(xlCellTypeLastCell).Column
    If lc > j Then j = lc
    i = i + lr
  Next
  ReDim b(1 To i, 1 To j)
  Set dic = CreateObject("Scripting.Dictionary")
  
  For Each sh In Sheets
    Set f = sh.Cells.Find(TextBox1.Value, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        If Not dic.exists(sh.Name & "|" & f.Row) Then
          dic(sh.Name & "|" & f.Row) = Empty
          k = k + 1
          For j = 1 To UBound(b, 2)
            b(k, j) = sh.Cells(f.Row, j).Value
          Next
        End If
        Set f = sh.Cells.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
  With ListBox1
    .Clear
    .ColumnCount = UBound(b, 2) + 1
    .List = b
  End With
End Sub

 

[NinetalesOCE]

Good morning and thank you for taking your time to help me!

I tried what you said and edited it all to fit my userform, but it appears to be showing an error for me.

Private Sub cmdSearch_Click()
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim r As Range, f As Range, cell As String
  Dim sh As Worksheet
  Dim dic As Object
  Dim b As Variant
  
  If offencetxt.Value = "" Then
    MsgBox "Enter value in textbox1"
    offencetxt.SetFocus
  End If
  
  For Each sh In Sheets
    lr = sh.Cells.SpecialCells(xlCellTypeLastCell).Row
    lc = sh.Cells.SpecialCells(xlCellTypeLastCell).Column
    If lc > j Then j = lc
    i = i + lr
  Next
  ReDim b(1 To i, 1 To j)
  Set dic = CreateObject("Scripting.Dictionary")
  
  For Each sh In Sheets
    Set f = sh.Cells.Find(offencetxt.Value, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        If Not dic.exists(sh.Name & "|" & f.Row) Then
          dic(sh.Name & "|" & f.Row) = Empty
          k = k + 1
          For j = 1 To UBound(b, 2)
            b(k, j) = sh.Cells(f.Row, j).Value
          Next
        End If
        Set f = sh.Cells.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
  With lstDatabase
    .Clear
    .ColumnCount = UBound(b, 2) + 1
    .List = b
  End With
End Sub

It seems to show error 50290 "Application-defined or object-defined error" and highlighting the line:

lr = sh.Cells.SpecialCells(xlCellTypeLastCell).Row

 

[DanteAmor]

Are you running the macro on the sheets?
Do you have the sheets hidden or protected or is the book hidden?

You can run on a new workbook and new sheets, with some data, just to test the code.

 

[NinetalesOCE]

ADVERTISEMENT

Are you running the macro on the sheets?
Do you have the sheets hidden or protected or is the book hidden?

You can run on a new workbook and new sheets, with some data, just to test the code.

It seems to work perfect if I do it from a fresh excel spreadsheet!

Thank you so much for your help.

One more question if you don't mind - is there a way to have those discovered cells copied onto a worksheet?

I was hoping to have a separate worksheet titled "SearchData" and when the user presses "View on Excel" command button after searching for the keyword, it will close the userform and populate the found data onto that sheet.

 

[DanteAmor]

I was hoping to have a separate worksheet titled "SearchData"

Try this:

Private Sub CommandButton1_Click()
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim r As Range, f As Range, cell As String
  Dim sh As Worksheet, sh2 As Worksheet
  Dim dic As Object
  Dim b As Variant
  
  If TextBox1.Value = "" Then
    MsgBox "Enter value in textbox1"
    TextBox1.SetFocus
  End If
  For Each sh In Sheets
    lr = sh.Cells.SpecialCells(xlCellTypeLastCell).Row
    lc = sh.Cells.SpecialCells(xlCellTypeLastCell).Column
    If lc > j Then j = lc
    i = i + lr
  Next
  ReDim b(1 To i, 1 To j)
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh2 = Sheets("SearchData")
  
  For Each sh In Sheets
    If sh.Name <> sh2.Name Then
      Set f = sh.Cells.Find(TextBox1.Value, , xlValues, xlPart, , , False)
      If Not f Is Nothing Then
        cell = f.Address
        Do
          If Not dic.exists(sh.Name & "|" & f.Row) Then
            dic(sh.Name & "|" & f.Row) = Empty
            k = k + 1
            For j = 1 To UBound(b, 2)
              b(k, j) = sh.Cells(f.Row, j).Value
            Next
          End If
          Set f = sh.Cells.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
      End If
    End If
  Next
  With ListBox1
    .Clear
    .ColumnCount = UBound(b, 2) + 1
    .List = b
  End With
  sh2.Cells.ClearContents
  sh2.Range("A2").Resize(k, UBound(b, 2)).Value = b
End Sub

 

[NinetalesOCE]

ADVERTISEMENT

Try this:

Private Sub CommandButton1_Click()
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim r As Range, f As Range, cell As String
  Dim sh As Worksheet, sh2 As Worksheet
  Dim dic As Object
  Dim b As Variant
 
  If TextBox1.Value = "" Then
    MsgBox "Enter value in textbox1"
    TextBox1.SetFocus
  End If
  For Each sh In Sheets
    lr = sh.Cells.SpecialCells(xlCellTypeLastCell).Row
    lc = sh.Cells.SpecialCells(xlCellTypeLastCell).Column
    If lc > j Then j = lc
    i = i + lr
  Next
  ReDim b(1 To i, 1 To j)
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh2 = Sheets("SearchData")
 
  For Each sh In Sheets
    If sh.Name <> sh2.Name Then
      Set f = sh.Cells.Find(TextBox1.Value, , xlValues, xlPart, , , False)
      If Not f Is Nothing Then
        cell = f.Address
        Do
          If Not dic.exists(sh.Name & "|" & f.Row) Then
            dic(sh.Name & "|" & f.Row) = Empty
            k = k + 1
            For j = 1 To UBound(b, 2)
              b(k, j) = sh.Cells(f.Row, j).Value
            Next
          End If
          Set f = sh.Cells.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
      End If
    End If
  Next
  With ListBox1
    .Clear
    .ColumnCount = UBound(b, 2) + 1
    .List = b
  End With
  sh2.Cells.ClearContents
  sh2.Range("A2").Resize(k, UBound(b, 2)).Value = b
End Sub

That's incredible, thank you so much for your help!

Sorry I have one more question if that's okay.

If there is more than one textbox which has data that is to be crosschecked on each of the worksheet, is there a way to make it check more than one textbox values?

Set f = sh.Cells.Find(TextBox1.Value, , xlValues, xlPart, , , False)

For example if they put "Australia" in textbox2 and "Steven" in textbox1, is there a way for it to check both boxes for any rows that include both text?

 

[DanteAmor]

For example if they put "Australia" in textbox2 and "Steven" in textbox1, is there a way for it to check both boxes for any rows that include both text?

The line must contain the two texts?
That is, if the line only says "Australia" the macro does not include it, but if the line has "Australia" and "Steven", then it does include.

 

[NinetalesOCE]

Perhaps I could explain it better with a picture.

You can see in the attached picture that two boxes are filled with text, and ideally i would like for the search button to show results that include both of those boxes.

So if it says "America" and "District Attorney" in a spreadsheet row, it will return that result in the Listbox.

But if it only shows America, it will not return that result in the listbox unless the box with "America" is the only one that is filled out.

Does that make sense?

I'm sorry if i've made it overcomplicated for you.

 

[DanteAmor]

So if it says "America" and "District Attorney" in a spreadsheet row, it will return that result in the Listbox.
But if it only shows America, it will not return that result in the listbox unless the box with "America" is the only one that is filled out.

This is the updated code for 2 textbox:

Private Sub CommandButton1_Click()
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Dim r As Range, f As Range, rng As Range
  Dim sh As Worksheet, sh2 As Worksheet
  Dim cell As String, cad As String
  Dim a() As Variant, b As Variant
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh2 = Sheets("SearchData")
  
  If TextBox1.Value = "" Then
    MsgBox "Enter value in textbox1"
    TextBox1.SetFocus
    Exit Sub
  End If
  
  For Each sh In Sheets
    If sh.Name <> sh2.Name Then
      lr = sh.Cells.SpecialCells(xlCellTypeLastCell).Row
      lc = sh.Cells.SpecialCells(xlCellTypeLastCell).Column
      If lc > j Then j = lc
      i = i + lr
    End If
  Next
  ReDim b(1 To i, 1 To j)
  
  For Each sh In Sheets
    If sh.Name <> sh2.Name Then
      lr = sh.Cells.SpecialCells(xlCellTypeLastCell).Row
      lc = sh.Cells.SpecialCells(xlCellTypeLastCell).Column
      If lr = 1 Then lr = 2
      Erase a
      a = sh.Range("A1", sh.Cells(lr, lc)).Value
      For i = 1 To UBound(a, 1)
        cad = ""
        For j = 1 To UBound(a, 2)
          If Not IsError(a(i, j)) Then
            cad = cad & "|" & a(i, j)
          End If
        Next
        If InStr(1, cad, TextBox1.Value, vbTextCompare) > 0 And _
           InStr(1, cad, TextBox2.Value, vbTextCompare) > 0 And _
           Not dic.exists(sh.Name & "|" & i) Then
          dic(sh.Name & "|" & i) = Empty
          k = k + 1
          For j = 1 To UBound(a, 2)
            b(k, j) = a(i, j)
          Next
        End If
      Next
    End If
  Next
  
  With ListBox1
    sh2.Cells.ClearContents
    .Clear
    If k > 0 Then
      Set rng = sh2.Range("A2").Resize(k, UBound(b, 2))
      rng.Value = b
      .ColumnCount = UBound(b, 2) + 1
      .List = rng.Value
    Else
      MsgBox "No data"
    End If
  End With
End Sub