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

Mike___

New Member
Joined
Jul 18, 2019
Messages
12
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
 
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...
Code:
[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]
 
Upvote 0

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
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!
 
Upvote 0
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.
 
Last edited:
Upvote 0
Hi Rick,

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

Thanks once again to you both!
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,482
Messages
6,113,916
Members
448,533
Latest member
thietbibeboiwasaco

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