How to find more than one word in Excel?

[man]

Hello

For example, I want to find cells that contains these 2 words [disposable] [bottles] in any order or with any other words in between, the search result shown will be A4 cell and A5 cell. How to do it? (Unable to use Ctrl+F because Ctrl+F only can search for 1 word)

My A1 cell to A6 cell contents are below
A1 cell: A water bottle is a container that is used to hold liquids, mainly water, for the purpose of transporting a drink while travelling or while otherwise away from a supply of potable water.
A2 cell: Water bottles are usually made of plastic, glass, metal, or some combination of those substances.
A3 cell: in the past, water bottles were sometimes made of wood, bark, or animal skins such as leather, hide and sheepskin.
A4 cell: Water bottles can be either disposable or reusable.
A5 cell: Disposable water bottles are often sold filled with potable water, while reusable bottles are often sold empty.
A6 cell: Reusable water bottles help cut down on consumer plastic waste and carbon emissions.

I am using Excel 2021

Thanks

 

[man]

Change your Sheet2 to Output. This code loop through all the sheets in the workbook and return the result on the Output sheet.

Sub Extract()
    Dim a, b() As Variant
    Dim i As Long, j As Long, k As Long
    Dim ws As Worksheet
    Dim ws2 As Worksheet
   
    ' Change the name of Sheet2 to "Output"
    Set ws2 = ThisWorkbook.Worksheets("Output") ' Output sheet
   
    ' Clear previous data in the output sheet
    ws2.Cells.Clear
   
    ' Loop through each worksheet that is not named "Output"
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Output" Then
            a = ws.UsedRange.Value
           
            ' Count the number of matching elements
            For i = 1 To UBound(a, 1)
                For j = 1 To UBound(a, 2)
                    ' Add words here as needed with similar syntax
                    If InStr(1, a(i, j), "Sold", vbTextCompare) > 0 And _
                       InStr(1, a(i, j), "Disposable", vbTextCompare) > 0 And _
                       InStr(1, a(i, j), "Bottles", vbTextCompare) > 0 Then
                       ReDim Preserve b(1 To k, 1 To 1)
                       b(k, 1) = a(i, j)
                       k = k + 1
                    End If
                Next j
            Next i
        End If
    Next ws
   
    ' Output the results to the "Output" sheet
    ws2.Range("A1").Resize(UBound(b, 1), 1).Value = b
End Sub

After press F5, I see this Run-time error '9': Subscript out of range

 

[Cubist]

when you hit debug which line is yellow?

 

[man]

when you hit debug which line is yellow?

ReDim Preserve b(1 To k, 1 To 1)

 

[Cubist]

Sub Extract()
    Dim a, b() As Variant
    Dim i As Long, j As Long, k As Long
    Dim ws As Worksheet
    Dim ws2 As Worksheet
   
    ' Change the name of Sheet2 to "Output"
    Set ws2 = ThisWorkbook.Worksheets("Output") ' Output sheet
   
    ' Clear previous data in the output sheet
    ws2.Cells.Clear
   k = 1
   ReDim b(1 To 10 * 6, 1 To 1)
    ' Loop through each worksheet that is not named "Output"
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Output" Then
            a = ws.Range("A1").CurrentRegion
           
            ' Count the number of matching elements
            For i = 1 To UBound(a, 1)
                For j = 1 To UBound(a, 2)
                    ' Add words here as needed with similar syntax
                    If InStr(1, a(i, j), "Sold", vbTextCompare) > 0 And _
                       InStr(1, a(i, j), "Disposable", vbTextCompare) > 0 And _
                       InStr(1, a(i, j), "Bottles", vbTextCompare) > 0 Then
                       b(k, 1) = a(i, j)
                       k = k + 1
                    End If
                Next j
            Next i
        End If
    Next ws
   
    ' Output the results to the "Output" sheet
    If k > 0 Then
        ws2.Range("A1").Resize(k, 1).Value = b
    End If
End Sub

 

[man]

Sub Extract()
    Dim a, b() As Variant
    Dim i As Long, j As Long, k As Long
    Dim ws As Worksheet
    Dim ws2 As Worksheet
  
    ' Change the name of Sheet2 to "Output"
    Set ws2 = ThisWorkbook.Worksheets("Output") ' Output sheet
  
    ' Clear previous data in the output sheet
    ws2.Cells.Clear
   k = 1
   ReDim b(1 To 10 * 6, 1 To 1)
    ' Loop through each worksheet that is not named "Output"
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Output" Then
            a = ws.Range("A1").CurrentRegion
          
            ' Count the number of matching elements
            For i = 1 To UBound(a, 1)
                For j = 1 To UBound(a, 2)
                    ' Add words here as needed with similar syntax
                    If InStr(1, a(i, j), "Sold", vbTextCompare) > 0 And _
                       InStr(1, a(i, j), "Disposable", vbTextCompare) > 0 And _
                       InStr(1, a(i, j), "Bottles", vbTextCompare) > 0 Then
                       b(k, 1) = a(i, j)
                       k = k + 1
                    End If
                Next j
            Next i
        End If
    Next ws
  
    ' Output the results to the "Output" sheet
    If k > 0 Then
        ws2.Range("A1").Resize(k, 1).Value = b
    End If
End Sub

After press F5, I see this

When I click debug this line is yellow
For i = 1 To UBound(a, 1)

 

[Cubist]

Replace

a = ws.Range("A1").CurrentRegion

with

a = ws.UsedRange.Value

 

[man]

Replace

a = ws.Range("A1").CurrentRegion

with

a = ws.UsedRange.Value

Replace done.
After press F5, I see this

When I click debug this line is yellow
For i = 1 To UBound(a, 1)

 

[Cubist]

Is one of your sheets empty? If it is then there's nothing to find. This should handle when that happens.

Sub Extract()
    Dim a, b() As Variant
    Dim i As Long, j As Long, k As Long
    Dim ws As Worksheet
    Dim ws2 As Worksheet
  
    ' Change the name of Sheet2 to "Output"
    Set ws2 = ThisWorkbook.Worksheets("Output") ' Output sheet
  
    ' Clear previous data in the output sheet
    ws2.Cells.Clear
    k = 1
    ReDim b(1 To 2 ^ 20, 1 To 1)
   
    ' Loop through each worksheet that is not named "Output"
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Output" Then
              a = ws.UsedRange.Value
            ' Check if the worksheet has any used range
            If Not IsEmpty(a) Then
                ' Count the number of matching elements
                For i = 1 To UBound(a, 1)
                    For j = 1 To UBound(a, 2)
                        ' Add words here as needed with similar syntax
                        On Error Resume Next
                        If InStr(1, a(i, j), "Sold", vbTextCompare) > 0 And _
                           InStr(1, a(i, j), "Disposable", vbTextCompare) > 0 And _
                           InStr(1, a(i, j), "Bottle", vbTextCompare) > 0 Then
                           b(k, 1) = a(i, j)
                           k = k + 1
                        End If
                        On Error GoTo 0
                    Next j
                Next i
            End If
        End If
    Next ws
  
    ' Output the results to the "Output" sheet
    If k > 0 Then
        ws2.Range("A1").Resize(k, 1).Value = b
    End If
End Sub

 

[man]

Is one of your sheets empty? If it is then there's nothing to find. This should handle when that happens.

Sub Extract()
    Dim a, b() As Variant
    Dim i As Long, j As Long, k As Long
    Dim ws As Worksheet
    Dim ws2 As Worksheet
 
    ' Change the name of Sheet2 to "Output"
    Set ws2 = ThisWorkbook.Worksheets("Output") ' Output sheet
 
    ' Clear previous data in the output sheet
    ws2.Cells.Clear
    k = 1
    ReDim b(1 To 2 ^ 20, 1 To 1)
  
    ' Loop through each worksheet that is not named "Output"
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Output" Then
              a = ws.UsedRange.Value
            ' Check if the worksheet has any used range
            If Not IsEmpty(a) Then
                ' Count the number of matching elements
                For i = 1 To UBound(a, 1)
                    For j = 1 To UBound(a, 2)
                        ' Add words here as needed with similar syntax
                        On Error Resume Next
                        If InStr(1, a(i, j), "Sold", vbTextCompare) > 0 And _
                           InStr(1, a(i, j), "Disposable", vbTextCompare) > 0 And _
                           InStr(1, a(i, j), "Bottle", vbTextCompare) > 0 Then
                           b(k, 1) = a(i, j)
                           k = k + 1
                        End If
                        On Error GoTo 0
                    Next j
                Next i
            End If
        End If
    Next ws
 
    ' Output the results to the "Output" sheet
    If k > 0 Then
        ws2.Range("A1").Resize(k, 1).Value = b
    End If
End Sub

One of my sheets is empty. I try your latest code with one empty sheet it has the error as seen below. I then deleted the empty sheet so no empty sheet and then try your latest code and it has the error as seen below. With or without empty sheet same error.

After press F5, I see this

When I click debug this line is yellow
For i = 1 To UBound(a, 1)

 

[man]

Question: Output is not renamed from Sheet2, I forgot what sheet number is renamed to Output, is it ok? I do not have Sheet2 anymore. I now insert new sheet it would be Sheet9 and above. I forgot what Sheet number I rename to Output. I added more sheets for testing so I think I deleted Sheet2.