Large Excel Document - remove entries (multiple)

Hi there,

I have a large excel file (it will have tens of thousands of entries in) and I would like to filter and delete out rows that are not needed (because the file is so large copying it makes the computer hang!).

I would like help in identifying the best way to use VBA to remove rows based on a criteria - but I am not sure the criteria is the easy to do.

I would like to remove any row where Email 1 equals Email 2 BUT the date in (Week Ending) must also be in the last 15 days.

On top of this I would like to remove any row where the value in column B is Xe. I would also like to remove any row where the value in column Q is Service 44!

Any help is greatly appreciated - my example workbook is attached.


Who is Participating?

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

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.

So it looks like you have 4 criteria to check.

I'd iterate through each row and then check the row for the criteria. Since you want to remove rows along the way, you will either need to decrement the counter when you remove a row, or start at the end and work your way backwards, which might be quicker.

Try something like this:
Sub CleanRows()
   Dim row as Integer
   For row = Selection.SpecialCells(xlCellTypeLastCell).Row to 1 step -1
      If RowToRemove(row) Then
         'Rows("1:1").Delete Shift:=xlUp   ' <= comment this out until you have a chance to verify that it is working
         Debug.print "deleted row " & row
      End If
End Sub

Function RowToRemove(row As Integer) as Boolean
   Dim CanRemove As Boolean
   Const Email1Column = 9991
   Const Email2Column = 9992
   Const WeekEndingColumn = 9993
   Const BColumn = 2
   Const QColumn = 17
   CanRemove = False

   if cells(row, Email1Column).value = cells(row, Email2Column).value then
      CanRemove = True
   ElseIf cells(row, WeekEndingColumn).value < now()-15 Then
      CanRemove = True
   ElseIf cells(row, BColumn).value = "Xe" Then
      CanRemove = True
   ElseIf cells(row, QColumn).value = "Service 44" Then
      CanRemove = True
   End If

   RowToRemove = CanRemove
End Function

Open in new window

oh, and change the constants in RowToRemove to match the correct columns
Michael FowlerSolutions ConsultantCommented:
This will do it for you. The public const value are just to make it easier to change columns. I also used caps insensitive comparisons just to be sure

Public Const GE_TYPE As String = "B"
Public Const EMAIL_1 As String = "F"
Public Const EMAIL_2 As String = "H"
Public Const WEEK_ENDING As String = "K"
Public Const SERVICE_TYPE As String = "Q"

Sub Filter()
    Dim lastrow As Long, i As Long
    Dim delete As Boolean
    lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = lastrow To 2 Step -1
        delete = False
        If UCase(Range(EMAIL_1 & i).Value) = UCase(Range(EMAIL_2 & i).Value) And _
                Now - Range(WEEK_ENDING & i).Value > 15 Then
            delete = True
        ElseIf UCase(Range(GE_TYPE & i).Value) = "XE" Then
            delete = True
        ElseIf UCase(Range(SERVICE_TYPE & i).Value) = "SERVICE 44" Then
            delete = True
        End If
        If delete Then
            Range("A" & i).EntireRow.delete
        End If
    Application.ScreenUpdating = True
End Sub

Open in new window


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
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.