Cut row to new sheet if text is found within multiple columns

[Mike___]

Hi all,

I currently use conditional formatting for this task - but I am finding myself needing to do this more often so wished to set up a VBA rather than use a long winded work around. In the past I have successfully created VBA's by mixing and matching various codes. Sadly - I am unable to find a solution to this and I know it is a pretty easy one which I am finding annoying.

I am looking to search columns C to K for text (normally it is just a partial match I am after). And if found the entire row is cut and moved to sheet2. There will be some blank cells in the columns and the documents could contain 20 - 40k rows of data.

The below code works on a search for just column W but I was unable to add multiple columns to the code - Sorry. I believe the answers are contained in this link [FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]https://www.mrexcel.com/forum/excel-questions/855173-vba-lastrow.html but my attempts of adding to this code myself have failed.[/FONT]

The search term that I will be using will constantly change (in this instance Business*) - Although I could just change it each time in the VBA - in a perfect world I would like to add the word or partial word to be found in a box when the VBA is run to speed up the process.

If anyone could help I would be most grateful.

Thanks
Mike

Option Explicit
Sub Test()

Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long

Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")

For i = 2 To sht1.Cells(sht1.Rows.Count, "w").End(xlUp).Row
If sht1.Range("w" & i).Value Like "Business*" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "w").End(xlUp).Row + 1)
End If
Next i

End Sub

 

[Rick Rothstein]

Hi Rick,

This copies across the results to columns A to I in sheet 2 rather than to AE to AM.
I need the entire row copied across if keyword is found as there is data in the other columns that needs to move across too.

Okay, give this macro a try...

[table="width: 500"]
[tr]
	[td]Sub Copy_Rows_v2()
  Dim LastRow1 As Long, LastRow2 As Long, BlankCol As Long, strToFind As String, WS1 As Worksheet, WS2 As Worksheet
  Set WS1 = Sheets("[B][COLOR="#0000FF"]Sheet1[/COLOR][/B]")
  Set WS2 = Sheets("[B][COLOR="#FF0000"]Sheet2[/COLOR][/B]")
  BlankCol = WS1.Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column + 1
  LastRow1 = WS1.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
  On Error Resume Next
  LastRow2 = WS2.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
  If Err.Number Then LastRow2 = 1
  On Error GoTo 0
  strToFind = InputBox("Enter Keyword to be found")
  With WS1.Range(Cells(2, BlankCol), Cells(LastRow1, BlankCol))
    .Formula = "=MATCH(""" & strToFind & "*"",'" & WS1.Name & "'!AE2:AM2,0)"
    On Error Resume Next
    Intersect(WS1.Columns("A"), .SpecialCells(xlFormulas, xlNumbers).EntireRow).EntireRow.Copy WS2.Cells(LastRow2 + 1, "A")
    On Error GoTo 0
  End With
  WS1.Columns(BlankCol).Clear
  WS2.Columns(BlankCol).Clear
End Sub[/td]
[/tr]
[/table]

 

[Mike___]

Hi Peter,

It was my turn for a mistake - I had been using the old code. It works a treat! Thanks for your time on this.

Rick - I haven't had a chance to test your new code yet - I shall give it a go!

 

[Rick Rothstein]

Rick - I haven't had a chance to test your new code yet - I shall give it a go!

I would be interested to know if the code I posted worked or not. Also, if it works, your sense how it compared speedwise to Peter's code.

 

[Peter_SSs]

Hi Peter,

It works a treat! Thanks for your time on this.

Great! You are very welcome.

 

[Mike___]

Hi Rick,

Both codes work perfectly and both ran 10k of rows instantaneously.

Thanks once again to you both!

 

[Rick Rothstein]

Hi Rick,

Both codes work perfectly and both ran 10k of rows instantaneously.

Thanks once again to you both!

Thanks for getting back to me on that... much appreciated. And, of course, you are quite welcome.