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
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
41,844
Office Version
365
Platform
Windows
Welcome to the MrExcel board!

1. Does the (partial) text need to occur in both column C and column K on a particular row for that row to be copied?

2. Can you confirm that row 1 of Sheet1 contains headings?
 

Mike___

New Member
Joined
Jul 18, 2019
Messages
12
Hi Peter,

I was working on this today and I have merged some code I have found to (I believe) find a solution.
To answer your questions. The search term would only have to happen once for it to be pulled to sheet2 and row 1 of sheet1 and 2 would have headings.


A few things changed since I asked my question. Search changed to columns
AE1:av5000 (If I wanted to change this to unlimited rows do i change this to AE:AV ?? and in this instance I copied the row across rather than cut (I believe that is changed by changing copy to cut?) Each time I search it adds to the found rows in sheet 2 which is what I want.

If there is a way to improve / make it quicker that would be great.
Thanks for your help.

Sub FindMe()
Dim intS As Long
Dim rngC As Range
Dim strToFind AsString, FirstAddress As String
Dim wSht AsWorksheet

Application.ScreenUpdating= False


'This step assumesthat you have a worksheet named
'Sheet2.
Set wSht =Worksheets("Sheet2")
intS =wSht.Range("A65536").End(xlUp).Row
strToFind =InputBox("Enter Keyword to be found")

'Change this rangeto suit your own needs.
WithActiveSheet.Range("AE1:av5000")
Set rngC =.Find(what:=strToFind, LookAt:=xlPart)
If Not rngC IsNothing Then
FirstAddress =rngC.Address
Do
rngC.EntireRow.CopywSht.Cells(intS, 1)
intS = intS + 1
Set rngC =.FindNext(rngC)
Loop While Not rngCIs Nothing And rngC.Address <> FirstAddress
End If
End With
MsgBox("Finished")
End Sub
 
Last edited by a moderator:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
41,844
Office Version
365
Platform
Windows
A few things changed since I asked my question. Search changed to columns
AE1:av5000
You are now looking for the search text in any one of 18 columns instead of just 2?


... in this instance I copied the row across rather than cut (I believe that is changed by changing copy to cut?)
What is your ultimate goal, copy or cut?
When I get to suggest some code, I will want to know which, as the code will be a little different for each.


If there is a way to improve / make it quicker that would be great.
I think there will be.
 

Mike___

New Member
Joined
Jul 18, 2019
Messages
12
Thanks Peter for your help and apologies for the confusion - I made a typo in yesterday's message.

I would like to search 9 columns. AE to AM

The ultimate goal is to copy.

Thanks
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
41,844
Office Version
365
Platform
Windows
I would like to search 9 columns. AE to AM

The ultimate goal is to copy.
Give this a try in a copy of your workbook.

Code:
Sub Copy_Rows()
  Dim a As Variant, b As Variant
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim nc As Long, lr As Long, i As Long, j As Long, k As Long, cols As Long
  Dim strToFind As String
  
  strToFind = InputBox("Enter Keyword to be found")
  If Len(strToFind) > 0 Then
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    With ws1
      nc = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                  SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
      lr = .Range("AE:AM").Find(What:="*", After:=.Range("AE1"), LookIn:=xlValues, SearchOrder:=xlByRows, _
                  SearchDirection:=xlPrevious, SearchFormat:=False).Row
      a = .Range("AE2:AM2").Resize(lr - 1).Value
    End With
    ReDim b(1 To UBound(a), 1 To 2)
    cols = UBound(a, 2)
    For i = 1 To UBound(a)
      b(i, 1) = i
      For j = 1 To cols
        If InStr(1, strToFind, a(i, j), 1) > 0 Then
          b(i, 2) = 1
          k = k + 1
          Exit For
        End If
      Next j
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With ws2
        lr = .Range("A" & .Rows.Count).End(xlUp).Row
      End With
      With ws1.Range("A2").Resize(UBound(a), nc + 1)
        .Columns(nc).Resize(, 2).Value = b
        .Sort Key1:=.Columns(nc + 1), Order1:=xlAscending, Header:=xlNo, _
              OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Resize(k).EntireRow.Copy Destination:=ws2.Range("A" & lr + 1)
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Columns(nc).Resize(, 2).ClearContents
      End With
      Application.ScreenUpdating = True
    End If
    MsgBox "Finished"
  Else
    MsgBox "Nothing to search for"
  End If
End Sub
 

Mike___

New Member
Joined
Jul 18, 2019
Messages
12
This was a lot quicker! However it seems to pick up extra rows. From what I can see it is where there are blanks in some of the columns it is searching.

Thanks
Mike
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
41,844
Office Version
365
Platform
Windows
However it seems to pick up extra rows. From what I can see it is where there are blanks in some of the columns it is searching.
Good point. :)
Another issue with the code is that it copies the data in the helper columns I use in Sheet1 to Sheet2

Try this version which should address both the above issues. Changed lines highlighted.
Rich (BB code):
Sub Copy_Rows_v2()
  Dim a As Variant, b As Variant
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim nc As Long, lr As Long, i As Long, j As Long, k As Long, cols As Long
  Dim strToFind As String
  
  strToFind = InputBox("Enter Keyword to be found")
  If Len(strToFind) > 0 Then
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    With ws1
      nc = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                  SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
      lr = .Range("AE:AM").Find(What:="*", After:=.Range("AE1"), LookIn:=xlValues, SearchOrder:=xlByRows, _
                  SearchDirection:=xlPrevious, SearchFormat:=False).Row
      a = .Range("AE2:AM2").Resize(lr - 1).Value
    End With
    ReDim b(1 To UBound(a), 1 To 2)
    cols = UBound(a, 2)
    For i = 1 To UBound(a)
      b(i, 1) = i
      For j = 1 To cols
        If Len(a(i, j)) > 0 Then
          If InStr(1, strToFind, a(i, j), 1) > 0 Then
            b(i, 2) = 1
            k = k + 1
            Exit For
          End If
        End If
      Next j
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With ws2
        lr = .Range("A" & .Rows.Count).End(xlUp).Row
      End With
      With ws1.Range("A2").Resize(UBound(a), nc + 1)
        .Columns(nc).Resize(, 2).Value = b
        .Sort Key1:=.Columns(nc + 1), Order1:=xlAscending, Header:=xlNo, _
              OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Resize(k, nc - 1).Copy Destination:=ws2.Range("A" & lr + 1)
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Columns(nc).Resize(, 2).ClearContents
      End With
      Application.ScreenUpdating = True
    End If
    MsgBox "Finished"
  Else
    MsgBox "Nothing to search for"
  End If
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
41,844
Office Version
365
Platform
Windows
Sadly nothing is copying across now?
That is not the case for me.

Is it possible for you to post a few rows of data from AE:AM and advise what text you entered in the search box? That way, I can see if I can replicate your problem.
 

Forum statistics

Threads
1,078,546
Messages
5,341,093
Members
399,418
Latest member
joterde

Some videos you may like

This Week's Hot Topics

  • Problem with Radio Button's format control
    I am creating an employee evaluation template (a sample is below) Column A is the category Column B, C D, E and F will be ratings (unacceptable...
  • Last Display on userform to a Listbox
    [CODE=vba] lstdisplay.ColumnCount = 15 lstdisplay.RowSource = "A1:O600000" [/CODE] So when i do this it Displays everything on the sheet i am...
  • Rename and move files to a new location
    Dear all, I have an excel file with the following information. The actual file name is at column A but i want to rename it using the following...
  • Help with True/False Formula
    Hello! Am stumped how to fix this formula, in which my result returns 'True', but it should return False. =IF(AG2=True...
  • Clear extra characters from a provided range of cells
    Dear All, I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when...
  • Help with Current and highest streaks
    Hi there, I've just joined the forum and this is my first post. I've already spent quite a bit of time searching the net and this forum for a...
Top