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

[NeedsomeHelp]

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.

[

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

]

 

[kevin9999]

You've asked 2 very distinct questions there. In answer to the first, the following code makes the following assumptions due to the absence of any sample data:

1. You are copying from "Sheet1" to "Sheet2"
2. Your data in sheet 1 is in column A and starts in row 1
3. Your key words could contain upper and lower case letters (as per your description)

Let's try this for a start on a copy of your data:

Option Explicit
Option Compare Text

Sub Needsomehelp()
    Dim i As Long, lr1 As Long, lr2 As Long, c As Range, arr() As Variant
    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
    
    For Each c In ws1.Range("A1:A" & lr1)
        If c.Value Like "*spotless*" Or _
        c.Value Like "*food*" Or _
        c.Value Like "*face*" Then
            ReDim Preserve arr(i)
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
    
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 1, Array(arr), 7
        .Offset(1).Copy ws2.Range("A" & lr2)
        .AutoFilter
    End With

End Sub

 

[kevin9999]

EDITED

Option Explicit
Option Compare Text

Sub Needsomehelp_2()
    Dim i As Long, lr1 As Long, lr2 As Long, c As Range, arr() As Variant
    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
    
    For Each c In ws1.Range("A1:A" & lr1)
        If c.Value Like "*spotless*" Or _
        c.Value Like "*food*" Or _
        c.Value Like "*face*" Then
            ReDim Preserve arr(i)
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
    
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 1, Array(arr), 7
        .Copy ws2.Range("A" & lr2)
        .AutoFilter
    End With

End Sub

 

[NeedsomeHelp]

Hi, when i try to run the edited code i get error 5 invalid procedure call on argument on line:

.AutoFilter 1, Array(arr) 7,

 

[kevin9999]

Hi, when i try to run the edited code i get error 5 invalid procedure call on argument on line:

.AutoFilter 1, Array(arr) 7,

That is strange. The only difference was that I took out the Offset(1) from the first code because you seem to have data from row 1. Did the unedited code (post #2) work for you?

 

[NeedsomeHelp]

Neither codes post #2 or #3 worked, same error on the same line.

 

[kevin9999]

Neither codes post #2 or #3 worked, same error on the same line.

OK, I'm flying blind here - both codes worked for me based on what I thought your data looked like. Before I look at this any further, I'll need to see your actual data. Please use the XL2BB Add in to provide it.

 

[NeedsomeHelp]

This is an example of the source data i am looking at but the row categories go out to 20 and columns go down to 40K.
In this example the code would copy and paste rows 2, 3 and 4 into a new sheet.

Description	Code	Layout	Transaction	Cost	Amount	Document Name	Flavour
r	e	t	r	f	f	h	h
the love of food	f	g	u	7​	56​	z	e
x	v	h	j	8​	65​	Light Spotless Dirty Area	r
s	a	Face	m	6​	435​	m	4​
f	t	r	e	w	r	t	y

 

[kevin9999]

You didn't use the XL2BB Add in as requested, but I've had a go based on your supplied image.
With this 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

And this original sheet 1:

Spotless.xlsb
	A	B	C	D	E	F	G	H
1	Description	Code	Layout	Transaction	Cost	Amount	Document Name	Flavour
2	r	e	t	r	f	f	h	h
3	the love of food	f	g	u	7	56	z	e
4	x	v	h	j	8	65	Light Spotless Dirty Area	r
5	s	a	Face	m	6	435	m	4
6	f	t	r	e	w	r	t	y
Sheet1

And this original sheet 2:

Spotless.xlsb
	A	B	C	D	E	F	G	H
1	Description	Code	Layout	Transaction	Cost	Amount	Document Name	Flavour
2
Sheet2

This is the result on sheet 2 after running the code:

Spotless.xlsb
	A	B	C	D	E	F	G	H
1	Description	Code	Layout	Transaction	Cost	Amount	Document Name	Flavour
2	the love of food	f	g	u	7	56	z	e
3	x	v	h	j	8	65	Light Spotless Dirty Area	r
4	s	a	Face	m	6	435	m	4
5
Sheet2

If that doesn't work the same for you, then I really will need to see your actual data using the XL2BB Add in.

 

[NeedsomeHelp]

Hi, it works!

Thankyou for being so patient and helping me out i really appreciate it.

Many thanks!