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

 

[Peter_SSs]

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___]

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

 

[Peter_SSs]

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___]

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]

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.

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___]

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]

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.

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

 

[Mike___]

Sadly nothing is copying across now?

 

[Peter_SSs]

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.