We help IT Professionals succeed at work.

move all rows containing key word in excel to new work sheet

Medium Priority
209 Views
Last Modified: 2010-04-16
I want to move all rows contaning a key word or words to a new work sheet.
here is some code i wrote to delete all rows containg a key word in column 2
or better yet if i could pass it the name of the word in an imput box and also list the column number in an imput box

any help would be appriciated.

Sub test()
     
    Dim ws As Worksheet
    Dim end_row, r As Integer

    For Each ws In Worksheets
        If ws.Name <> " test"
            end_row = ws.Cells(65536, 25).End(xlUp).Row
            For r = end_row To 1 Step -1
                If Cells(r, 2).Value = "anonymous" Then
                    Rows(r).EntireRow.Delete              
                End If
            Next
      End If
    Next
End Sub
Comment
Watch Question

Commented:
Try this, just change your sheet names and your done:

Sub subFindandCopy()
    Dim c As Range
    Dim strColumn As String
    Dim strFind As String
    strColumn = InputBox("Type a column letter")
    strFind = InputBox("Enter a search criteria")
    With Worksheets("Sheet1").Range(strColumn & ":" & strColumn)
    Set c = .Find(strFind, LookIn:=xlValues, lookat:=xlPart)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.EntireRow.Copy Worksheets("Sheet2").Range("a65000").End(xlUp).Offset(1, 0)
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
    End With

End Sub

-David251

Author

Commented:
sweet works but does not delet from first sheet

thanks

Commented:
Sub subFindandCopyandDelete()
    Dim c As Range
    Dim strColumn As String
    Dim strFind As String
    strColumn = InputBox("Type a column letter")
    strFind = InputBox("Enter a search criteria")
    With Worksheets("Sheet1").Range(strColumn & ":" & strColumn)
    Set c = .Find(strFind, LookIn:=xlValues, lookat:=xlPart)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.EntireRow.Copy Worksheets("Sheet2").Range("a65000").End(xlUp).Offset(1, 0)
            c.EntireRow.Delete
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
    End With

End Sub

-David251

Author

Commented:
it is not looping
it will copy and delete the first string ie "test"
but then will bomb

the first code works as designed

Commented:
Sorry, I forgot it needs c in the next iteration, try this:

Sub subFindandCopyandDelete()
    Dim c As Range, d as Range
    Dim strColumn As String
    Dim strFind As String
    strColumn = InputBox("Type a column letter")
    strFind = InputBox("Enter a search criteria")
    With Worksheets("Sheet1").Range(strColumn & ":" & strColumn)
    Set c = .Find(strFind, LookIn:=xlValues, lookat:=xlPart)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.EntireRow.Copy Worksheets("Sheet2").Range("a65000").End(xlUp).Offset(1, 0)
            set d=c
            Set c = .FindNext(c)
            d.EntireRow.Delete
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
    End With

End Sub

Author

Commented:
it is still only doing one row
one copy an one delete but no errors :)

Author

Commented:
Ok i made a function to go along with your code and that seems to work but i need some help on it now

Here it is

Public Function delete()

     
    Dim ws As Worksheet
    Dim end_row, r As Integer

    For Each ws In Worksheets
        If ws.Name <> " sheet1" Then
            end_row = ws.Cells(65536, 25).End(xlUp).Row
            For r = end_row To 1 Step -1
                If Cells(r, 2).Value = strFind Then  I NEED IT TO PULL THE COLUM LETTER FROM THE IMPUT  BOX LIKE I HAVE IT FOR THE TEXT
                    Rows(r).EntireRow.delete              
                End If
            Next
      End If
     
    Next


End Function
Commented:
This will work for you.

Sub subFindandCopyandDelete()
    Dim c As Range, d As Range
    Dim strColumn As String
    Dim strFind As String
    strColumn = InputBox("Type a column letter")
    strFind = InputBox("Enter a search criteria")
    With Worksheets("Sheet1").Range(strColumn & ":" & strColumn)
    Set c = .Find(strFind, LookIn:=xlValues, lookat:=xlPart)
    If Not c Is Nothing Then
        Do
            On Error GoTo enditnow
            c.EntireRow.Copy Worksheets("Sheet2").Range("a65000").End(xlUp).Offset(1, 0)
            Set d = c
            Set c = .FindNext(c)
            d.EntireRow.Delete
        Loop While Not c Is Nothing
    End If
    End With
enditnow:
   
End Sub

Not the solution you were looking for? Getting a personalized solution is easy.

Ask the Experts

Author

Commented:
your a life saver thank you

Commented:

Glad I could help:-)
Thanks for the points/grade.
-David251

Author

Commented:
no problem i think i got it now
i will post another question so you can get some more points
because say the word i want to copy and delete is test it will copy and delete test1 test\company anything that has test in it so is there a way to make it match exact?

Commented:
change this:
Set c = .Find(strFind, LookIn:=xlValues, lookat:=xlPart)
to this
Set c = .Find(strFind, LookIn:=xlValues, lookat:=xlWhole)

No need to post another question
Access more of Experts Exchange with a free account
Thanks for using Experts Exchange.

Create a free account to continue.

Limited access with a free account allows you to:

  • View three pieces of content (articles, solutions, posts, and videos)
  • Ask the experts questions (counted toward content limit)
  • Customize your dashboard and profile

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.