Cut row to new sheet if text is found within multiple columns
Page 1 of 3 123 LastLast
Results 1 to 10 of 26

Thread: Cut row to new sheet if text is found within multiple columns
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Jul 2019
    Posts
    12
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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 https://www.mrexcel.com/forum/excel-questions/855173-vba-lastrow.html but my attempts of adding to this code myself have failed.

    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

  2. #2
    MrExcel MVP
    Moderator
    Peter_SSs's Avatar
    Join Date
    May 2005
    Location
    Macksville, Australia
    Posts
    40,011
    Post Thanks / Like
    Mentioned
    81 Post(s)
    Tagged
    18 Thread(s)

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

    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?
    Hope this helps, good luck.
    Peter
    Excel 365 - Windows 10
    - Want to help your helpers by posting a small, copyable, screen shot directly in your post? Look here
    - If posting vba code, please use Code Tags - like this [code]Paste code here[/code] - or use the VBHTML Maker
    - Read: Forum Rules, Forum Use Guidelines, & FAQ

  3. #3
    New Member
    Join Date
    Jul 2019
    Posts
    12
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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 Peter_SSs; Jul 22nd, 2019 at 03:09 AM. Reason: Font size

  4. #4
    MrExcel MVP
    Moderator
    Peter_SSs's Avatar
    Join Date
    May 2005
    Location
    Macksville, Australia
    Posts
    40,011
    Post Thanks / Like
    Mentioned
    81 Post(s)
    Tagged
    18 Thread(s)

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

    Quote Originally Posted by Mike___ View Post
    A few things changed since I asked my question. Search changed to columns [LEFT][COLOR=#222222]AE1:av5000
    You are now looking for the search text in any one of 18 columns instead of just 2?


    Quote Originally Posted by Mike___ View Post
    ... 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.


    Quote Originally Posted by Mike___ View Post
    If there is a way to improve / make it quicker that would be great.
    I think there will be.
    Hope this helps, good luck.
    Peter
    Excel 365 - Windows 10
    - Want to help your helpers by posting a small, copyable, screen shot directly in your post? Look here
    - If posting vba code, please use Code Tags - like this [code]Paste code here[/code] - or use the VBHTML Maker
    - Read: Forum Rules, Forum Use Guidelines, & FAQ

  5. #5
    New Member
    Join Date
    Jul 2019
    Posts
    12
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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

  6. #6
    MrExcel MVP
    Moderator
    Peter_SSs's Avatar
    Join Date
    May 2005
    Location
    Macksville, Australia
    Posts
    40,011
    Post Thanks / Like
    Mentioned
    81 Post(s)
    Tagged
    18 Thread(s)

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

    Quote Originally Posted by Mike___ View Post
    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
    Hope this helps, good luck.
    Peter
    Excel 365 - Windows 10
    - Want to help your helpers by posting a small, copyable, screen shot directly in your post? Look here
    - If posting vba code, please use Code Tags - like this [code]Paste code here[/code] - or use the VBHTML Maker
    - Read: Forum Rules, Forum Use Guidelines, & FAQ

  7. #7
    New Member
    Join Date
    Jul 2019
    Posts
    12
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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

  8. #8
    MrExcel MVP
    Moderator
    Peter_SSs's Avatar
    Join Date
    May 2005
    Location
    Macksville, Australia
    Posts
    40,011
    Post Thanks / Like
    Mentioned
    81 Post(s)
    Tagged
    18 Thread(s)

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

    Quote Originally Posted by Mike___ View Post
    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.
    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
    Hope this helps, good luck.
    Peter
    Excel 365 - Windows 10
    - Want to help your helpers by posting a small, copyable, screen shot directly in your post? Look here
    - If posting vba code, please use Code Tags - like this [code]Paste code here[/code] - or use the VBHTML Maker
    - Read: Forum Rules, Forum Use Guidelines, & FAQ

  9. #9
    New Member
    Join Date
    Jul 2019
    Posts
    12
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    Sadly nothing is copying across now?

  10. #10
    MrExcel MVP
    Moderator
    Peter_SSs's Avatar
    Join Date
    May 2005
    Location
    Macksville, Australia
    Posts
    40,011
    Post Thanks / Like
    Mentioned
    81 Post(s)
    Tagged
    18 Thread(s)

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

    Quote Originally Posted by Mike___ View Post
    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.
    Hope this helps, good luck.
    Peter
    Excel 365 - Windows 10
    - Want to help your helpers by posting a small, copyable, screen shot directly in your post? Look here
    - If posting vba code, please use Code Tags - like this [code]Paste code here[/code] - or use the VBHTML Maker
    - Read: Forum Rules, Forum Use Guidelines, & FAQ

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •