asked on

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

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

david251

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

ZJY0021

ASKER

sweet works but does not delet from first sheet

thanks

david251

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

ZJY0021

ASKER

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

the first code works as designed

david251

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

ZJY0021

ASKER

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

ZJY0021

ASKER

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

ASKER CERTIFIED SOLUTION

david251

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

ZJY0021

ASKER

your a life saver thank you

david251

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

ZJY0021

ASKER

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?

david251

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