Strip out / copy values when condition met

Hi I have this code which removed all values in a column where it does not equal successful but I am not sure how to amend it for another purpose.

I would like to define  a number of specific values and move these to another sheet in the spreadsheet where the following conditions are met:

the cell value does not equal @bewx.com
or
the cell value contrains xxx.xxx@

If either of these are contained in any value in  column D can it be copied (the whole row) from the current worksheet to another worksheet called None?

Can these be worked in to the code in anyway?

Dim lRow
lRow = 3000
Do While lRow >= 2
If Cells(lRow, 9) <> "Successful" Then Rows(lRow).Delete
lRow = lRow - 1
Loop
gisvpnAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
gisvpnAuthor Commented:
Hi Roy,

Thanks for your post on the other thread for a different question - I am not sure where this question is answered on the other question - in terms of including :

•the cell value does not equal @bewx.com

or
 
•the cell value contrains xxx.xxx@
gisvpnAuthor Commented:
Can I add OR conditions to this part?

 If rCl.Value <> "Successful" Then.... of your solution?


Option Explicit

 Sub DeleteRows()
     Dim rRng As Range, rDelete As Range, rCl As Ranges

     Set rRng = Cells(1, 9).CurrentRegion    '///limits the number of Rows

     For Each rCl In rRng
         If rCl.Value <> "Successful" Then
             If rDelete Is Nothing Then
                 Set rDelete = rCl
             Else: Set rDelete = Union(rDelete, rCl)
             End If
         End If
     Next rCl
     If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
 End Sub 

Open in new window

PMI ACP® Project Management

Prepare for the PMI Agile Certified Practitioner (PMI-ACP)® exam, which formally recognizes your knowledge of agile principles and your skill with agile techniques.

Roy CoxGroup Finance ManagerCommented:
As I said in the other post, the AutoFilter method will be faster and can have two conditions. For more criteria AdvancedFilter would be better.
gisvpnAuthor Commented:
So coming back to this question how can these be worked in - how would I do it?!
Roy CoxGroup Finance ManagerCommented:
Can you provide an example workbook
gisvpnAuthor Commented:
Sure thing let me grab one - will post back soon ;)
gisvpnAuthor Commented:
Hi Roy - please see the example workbook.
Example-Workbook-1.xlsx
Roy CoxGroup Finance ManagerCommented:
Try this code

Option Explicit


Sub ClearEntries()
    Dim rCl As Range, rData As Range, rCopy As Range
    Set rData = Sheet1.Range("A1").CurrentRegion.Columns(5)

    For Each rCl In rData.Cells
        If Right(rCl.Value, 9) = "@bewx.com" Or Left(rCl.Value, 8) = "xxx.xxx@" Then
            If rCopy Is Nothing Then
                Set rCopy = rCl
            Else: Set rCopy = Union(rCopy, rCl)
            End If
        End If
    Next rCl
    If Not rCopy Is Nothing Then
        rCopy.Copy Sheet2.Range("A1")
        rCopy.EntireRow.Delete
    End If
End Sub

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Martin LissOlder than dirtCommented:
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.