Use keyword to find word in table and copy and paste in new sheet.

NeedsomeHelp

New Member
Joined
Jul 12, 2022
Messages
6
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows
Hi,

What I'm trying to do is use a keyword e.g. "Spotless" and with that keyword find any cell in the source data sheet with that keyword (could be in the middle of the word, end, start thats why it has wildcards) and if it has that keyword copy and paste the whole row in a new sheet.

The problem i have with the code now is that it will only work for one keyword How do i get it to work with multiple keywords say i want the keywords "spotless" "food" and "face" what would i need to do for the code to pick up all three keywords and copy and paste those in a new sheet.

If it is possible as well would i be able to use a different sheet named Keywords which would have a single column with different keywords in the column and the code would search for all the keywords in the column one after the other and copy and paste it in a new sheet.

VBA Code:
[

Sub Test1()
Application.ScreenUpdating = True
Dim xRow&, NextRow&, LastRow&
NextRow = 2
LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For xRow = 1 To LastRow

If WorksheetFunction.CountIf(Rows(xRow), "*Spotless*") > 0 Then
Rows(xRow).Copy Sheets("Sheet2").Rows(NextRow)
NextRow = NextRow + 1
End If
Next xRow
Application.ScreenUpdating = True
End Sub

]
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Hi,
I need some additional help if that would be possible.

I'm trying to add more than 25 keywords into the code, however i get the "too many line continuations error" because there is the same line 25 times. This is the code i've added in but 25 times for different keywords.

Is it possible instead of putting words in "*XXXX*" format in the VBA code to having the code pick up the keywords from a sheet column and turn that into an array? I've linked the excel spreadsheet i would like to use for keywords used from a sheet.

Book1.xlsx
A
1keywords
2spotless
3food
4cat
5dog
6zoom
7face
Sheet1
[/CODE]

VBA Code:
[/
 For i = LBound(arr1, 1) To UBound(arr1, 1)
        For j = LBound(arr1, 2) To UBound(arr1, 2)
            If arr1(i, j) Like "*spotless*" Or _
                arr1(i, j) Like "*food*" Or _
                arr1(i, j) Like "*cat*" Or _
                arr1(i, j) Like "*dog*" Or _
                arr1(i, j) Like "*zoom*" Or _
                arr1(i, j) Like "*face*" Then
                    arr2(i, 1) = 1
            End If
        Next j
    Next i
]
 
Upvote 0
hello,
where could i insert an else statement if no keywords were found from this list.
like it will return a msgbox that says nothing were found.

You didn't use the XL2BB Add in as requested, but I've had a go based on your supplied image.
With this code:

VBA Code:
Option Explicit
Option Compare Text
Sub Needsomehelp_3()
   
    Dim i As Long, j As Long, lr1 As Long, lr2 As Long, lc As Long
    Dim c As Range, arr1, arr2
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    lr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
   
    arr1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(lr1, lc - 1))
    ReDim arr2(1 To lr1, 1 To 1)
   
    For i = LBound(arr1, 1) To UBound(arr1, 1)
        For j = LBound(arr1, 2) To UBound(arr1, 2)
            If arr1(i, j) Like "*spotless*" Or _
                arr1(i, j) Like "*food*" Or _
                arr1(i, j) Like "*face*" Then
                    arr2(i, 1) = 1
            End If
        Next j
    Next i
   
    ws1.Cells(2, lc).Resize(lr1 - 1).Value = arr2
    With ws1.Range("A1").CurrentRegion
        .AutoFilter lc, 1
        .Offset(1).Resize(, lc - 1).Copy ws2.Range("A" & lr2)
        .AutoFilter
    End With
    ws1.Columns(lc).ClearContents

End Sub
 
Upvote 0
hello,
where could i insert an else statement if no keywords were found from this list.
like it will return a msgbox that says nothing were found.
Immediately before the End If, like this:

VBA Code:
Else
    MsgBox "Nothing found"
End If
 
Upvote 0
Immediately before the End If, like this:

VBA Code:
Else
    MsgBox "Nothing found"
End If
thanks for the immediate response. much appreciated.
however, adding the code above, returns a looping msgbox even with a found keyword.
 
Upvote 0
thanks for the immediate response. much appreciated.
however, adding the code above, returns a looping msgbox even with a found keyword.
I'll look at this again tomorrow, although you really should start a new thread.
 
Upvote 0
thanks for the immediate response. much appreciated.
however, adding the code above, returns a looping msgbox even with a found keyword.
I can only respond to the code I provided in post #9. Therefore, add the following lines of code to that:

Rich (BB code):
 If Application.Sum(arr2) = 0 Then
        MsgBox "Nothing found"
        Exit Sub
    Else
        ws1.Cells(2, lc).Resize(lr1 - 1).Value = arr2
        With ws1.Range("A1").CurrentRegion
            .AutoFilter lc, 1
            .Offset(1).Resize(, lc - 1).Copy ws2.Range("A" & lr2)
            .AutoFilter
        End With
        ws1.Columns(lc).ClearContents
    End If
 
Last edited:
Upvote 0
I can only respond to the code I provided in post #9. Therefore, add the following lines of code to that:

Rich (BB code):
 If Application.Sum(arr2) = 0 Then
        MsgBox "Nothing found"
        Exit Sub
    Else
        ws1.Cells(2, lc).Resize(lr1 - 1).Value = arr2
        With ws1.Range("A1").CurrentRegion
            .AutoFilter lc, 1
            .Offset(1).Resize(, lc - 1).Copy ws2.Range("A" & lr2)
            .AutoFilter
        End With
        ws1.Columns(lc).ClearContents
    End If
thank you very much!
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,184
Members
448,554
Latest member
Gleisner2

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