Filtering rows in Excel according to words, dates, and ID numbers

Question

I have 3 columns of ID, Field, and Date (Apologies, I do not know how to format so everything is neat in 3 columns):

id  field   date
1     a      1
1     b      1
1     d      1
1     a      2
1     s      2
1     d      2
2     a      3
2     d      3
2     b      4
2     s      4
1     w      1
1     q      1
1     b      2

I also have 2 named ranges, ww:

a
d

and xx:

b
s

The named ranges are possible values from the field column.

ww is a list of values I want to keep and xx is a list of values that are to be removed if and only if the corresponding value exists in ww for the same ID and on the same date.

That is, for the first entry, values 'a' and 'b' are compared for ID=1 and Date=1. If both are present, then I want to delete b (from the xx named range).

id  field   date
1     a     1
1     b     1

becomes:

id  field   date
1     a     1

The final result from the initial dataset becomes:

id  field   date
1     a      1
1     d      1
1     a      2
1     d      2
2     a      3
2     d      3
2     b      4
2     s      4
1     w      1
1     q      1

The code use is:

And this is what how I do it:

• filter based on the ith word to keep and remove combo

• filter based on ID number

• determine relevant dates, and filter by each of the relevant dates

• examine the field values and identify their row

• delete row if both are present

• repeat filter to check other days

• repeat filter to check other IDs

• repeat filter to check other word combo's

Note that I have 600k rows, 200 different values from field, and the date range covers 5 years of dates. My macro does it all, although it takes ~15 hours to run. Here is the macro that works:

Sub Manp()
Dim w1 As Range
Dim w2 As Range
Set w1 = Range("ww") 'named range of words to keep
Set w2 = Range("xx") 'named range of words to remove
O = Cells(Rows.Count, 1).End(xlUp).Row 'count number of records for specific id#
Application.ScreenUpdating = False

For i = 1 To w1.Rows.Count 'subset based on common fields, one to keep, one to remove
    Application.StatusBar = i
    v = Range(w1(i), w2(i))
    For Each j In [pp]
        Sheets("Sheet1").Select
        Selection.AutoFilter Field:=2, Criteria1:=v, Operator:=xlFilterValues 'filter by key fields
        Sheets("Sheet1").Range("$A$1:$C$15").AutoFilter Field:=1, Criteria1:=j ' filter by id#
        N3 = Cells(Rows.Count, 1).End(xlUp).Row
        If N3 > 1 Then
            Range("C2:C" & O).Copy Destination:=Sheets("Sheet4").Range("J1")
            Sheets("Sheet4").Select
            Columns(10).RemoveDuplicates Columns:=Array(1)
            N2 = Cells(Rows.Count, 10).End(xlUp).Row
            If N2 = 1 Then
                ddd = Range("J1:J" & N2 + 1).Value
                Else
                ddd = Range("J1:J" & N2).Value ' have unique list of days
            End If
            Columns(10).Clear
            Sheets("Sheet1").Select
             For Each k In ddd ' filter on each day
                Sheets("Sheet1").Select
                If Sheets("sheet1").AutoFilterMode Then Sheets("sheet1").ShowAllData
                Selection.AutoFilter Field:=2, Criteria1:=v, Operator:=xlFilterValues 'filter by key fields
                Sheets("Sheet1").Range("$A$1:$C$15").AutoFilter Field:=1, Criteria1:=j ' filter by id#
                Sheets("Sheet1").Range("$A$1:$C$15").AutoFilter Field:=3, Criteria1:=k
                 'check contents of cells
                Set visRng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible) ' Select only rows within the used range that are visible.
                Dim r As Range
                 Rowz = Sheets("Sheet1").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
                    If Rowz > 1 Then
                        r1 = 0
                        r2 = 0
                        For Each r In visRng.Rows ' Loop through each row in our visible range ...
                            If Cells(r.Row, 2) = w1(i) Then r1 = r.Row ' check if cell value is a keeper
                            If Cells(r.Row, 2) = w2(i) Then r2 = r.Row ' check if cell value is a discard wrt a keeper
                            If r1 > 0 And r2 > 0 Then Rows(r2).Delete ' check if both keeper and discard are in same subset
                        Next
                    End If
                Next k
            End If



        If Sheets("sheet1").AutoFilterMode Then Sheets("sheet1").ShowAllData
    Next j


Next i
Application.ScreenUpdating = True
End Sub

I would love any suggestions to improve the performance of this macro!

Answer 1

Whenever you are looking at processing times this long, it is a must to work with Arrays.

Whenever you are matching values in large list use a Collection (e.g. VBA.Collection, Scripting.Dictionary, System.Collections.ArrayList ...). In this instance I would use an ArrayList because we are only interested in unique values and not Key/Value pairs.

Good variable naming is key to good coding.

Sheets("Sheet1").Range("$A$1:$C$15").AutoFilter works? I assume that the VBA is automatically resizing the filter range. I also provide the correct range. Who knew.

.SpecialCells with no error handlers. That is asking for trouble.

Here is how to use .SpecialCells:

On Error Resume Next
Set visRng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not visRng Is Nothing Then

It is recommended that all Ranges be fully qualified. You should avoid Selecting or Activating objects unless truly necessary( watch: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)).

Here are the steps to quickly remove data from a large Range

• Define the Target Range
• Load the Target Range values into an Array
• Create a 2nd Array the same size as the 1st Array
• Load all the data that you want to keep into the 2nd Array
• Write the 2nd Array values over the Target values

This technique should reduce the run time from 15 hours to 25-45 seconds.

I am providing the code below as a demonstration. It is not meant to be a complete solution. I might have missed a few details in the OP's specifications.

Sub RemoveValues()
    Dim listKeep As Object, listNoDups As Object, list As Object, key As Variant, Target As Range
    Dim data As Variant, results As Variant
    Dim r As Long, r2 As Long
    Dim flag As Boolean

    Set dicKeep = getRangeList("ww")
    Set dicNoDups = getRangeList("xx")

    Set list = CreateObject("System.Collections.ArrayList")

    With Worksheets("Sheet1")
        Set Target = .Range("A1", .Range("C" & .Rows.count).End(xlUp))
    End With

    data = Target.Value

    ReDim results(1 To UBound(data), 1 To UBound(data, 2))

    For r = 1 To UBound(data)
        key = data(r, 1) & "|" & data(r, 2) & "|" & data(r, 3)
        flag = False

        If Not list.Contains(data(r, 2)) Then
            flag = True
        ElseIf dicKeep.Contains(data(r, 2)) Then
            flag = True
        ElseIf Not dicNoDups.Contains(data(r, 2)) Then
            'Does this even matter???
        End If


        If flag Then
            r2 = r2 + 1
            results(r2, 1) = data(r, 1)
            results(r2, 2) = data(r, 2)
            results(r2, 3) = data(r, 3)
        End If

        If Not list.Contains(key) Then list.Add key
    Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Target.Value = results

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Function getRangeList(RangeName As String) As Object
    Dim list As Object, key As Variant
    Set list = CreateObject("System.Collections.ArrayList")

    For Each key In Range(RangeName).Value
        list.Add key
    Next

    Set getRangeList = list
End Function

Answer 2

I don't know if your indentation was removed when you pasted the code, but you always want your code indented starting after Sub. It's good practice to indent all of your code that way Labels will stick out as obvious.

---

Option Explicit

Always turn on Option Explicit. You can have it automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option. This way if you have any variables not defined, the compiler will let you know.

If I place Option Explicit at the top, you have a ton of undeclared variables -

Dim O
Dim i
Dim v
Dim j
Dim N3
Dim N2
Dim ddd
Dim k
Dim visRng
Dim rowz
Dim r1
Dim r2

When you don't define your variable, VBA will declare it as a Variant, which are objects:

Performance. A variable you declare with the Object type is flexible enough to contain a reference to any object. However, when you invoke a method or property on such a variable, you always incur late binding (at run time). To force early binding (at compile time) and better performance, declare the variable with a specific class name, or cast it to the specific data type.

By not declaring variables, you could possibly be paying a penalty.

When you don't define your variable, VBA will declare it as a Variant type that can hold any type of data. While this may be more flexible, it adds processing time to your macro as VBA decides or tests for the type. Additionally, since a Variant can be any type of data, you may miss out on valuable troubleshooting information on Type Mismatch

---

Variable Naming

Speaking of variables, - give your variables meaningful names. Characters are free and can only help clarify the code. visRng can only be improved by renaming it visibleRange and it costs nothing.

All those variables you didn't declare, what could they possibly be? The names give you no idea what they could be, or even what type they should be. When you end up with variables that are numbered, you know the names can be improved. e.g.

i - targetRow
v - targetRange
N3 - lastRow
ddd - uniqueDays

etc.. See, before I would assume ddd was a range, but it's not, it's an array, because of the implicit type of ddd being a variant. Naming is a huge part of making your code more clear, even when it seems obvious what you're doing at the time, in 6 months or a year when you go back, you will have to go line by line to understand what you're doing. Declare those variables and give they good names!

Additionally, what does Manp mean? Tell me what your procedure is doing in the name.

---

Comments

Comments - "code tell you how, comments tell you why". The code should speak for itself, if it needs a comment, it might need to be made more clear. If not, the comment should describe why you're doing something rather than how you're doing it. Here are a few reasons to avoid comments all together.

O = Cells(Rows.Count, 1).End(xlUp).row 'count number of records for specific id#

Why not just

countOfRecords = Cells(Rows.Count,1).End(xlUp).row

See that variables name completely removed the comment. Yay.

---

Implicit Qualifiers

_{Courtesy Rubberduck-VBA}

When you don't qualify where a range is, it will implicitly assume it's activesheet. So

 Set w1 = Range("ww")

Is always going to be the active sheet. Tell me where the range is. In fact

Dim targetSheet As Worksheet
Dim wordsToKeepRange As Range
Dim wordsToRemoveRange As Range
Set wordsToKeepRange = targetSheet.Range("ww")
Set wordsToRemoveRange = targetSheet.Range("xx")

That works wonderfully. But those named ranges, what kind of names are those? Also, worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet.

Working in the sheet

Be sure to avoid things like .Select - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this.

Note that I have 600k rows, 200 different values from field, and the date range covers 5 years of dates. My macro does it all, although it takes ~15 hours to run.

YIKES. Simply moving your data into an array will likely decrease that time by a significant amount.

Dim lastRow As Long
lastRow = targetSheet.Cells(Rows.Count, 1).End(xlUp).row
Dim lastColumn As Long
lastColumn = targetSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim myData As Variant
myData = targetSheet.Range(Cells(1, 1), Cells(lastRow, lastColumn))

Now you can do everything in myData.

Application.StatusBar = i

Maybe this is for debugging, but it's going to slow you down, every single row. And that's with Application.ScreenUpdating = False?

Without rewriting your code, just by looking at your description you could start with something like

Const TARGET_DUPLICATES_COLUMN As Long = 621
Dim lastRow As Long
lastRow = targetSheet.Cells(Rows.Count, 1).End(xlUp).row
Dim lastColumn As Long
lastColumn = targetSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim rawData As Variant
rawData = targetSheet.Range(Cells(1, 1), Cells(lastRow, lastColumn))
Dim noDuplicateData As Variant
Dim arrayIndex As Long
For arrayIndex = LBound(rawData) To UBound(rawData)
    'look for duplicates and move them to new array
Next

---

In reality I would probably use a Scripting.Dictionary as it's pretty easy to avoid duplicates by adding members of the dictionary with value = 1, they cannot repeat. Then use that as your reference for clearing out rows. I'd also probably pull in some sort of sort to the array so I could arrange it by whatever fields I need to, that way if I iterate through the entire thing I should be able to match up duplicates as I go and just not copy them to the new array.

Answer 3

I don't have much to add to the existing answers, which are all pretty good ways of approaching the problem. But I figured I'd mention that a problem like this is much easier to solve when your data is in a database. With 600k rows, you're approaching the limits of what's possible (or at least advisable) to do in Excel. I'm all for creative VBA solutions, but when possible I like to integrate SQL in cases like this (ie store the data in a database, run the SQL query/populate the workbook from an ADODB connection via VBA).

Assuming your main data was in one table, and your "ww" and "xx" ranges were two columns named "tokeep" and "toremove" in another table, the SQL solution would be pretty straightforward:

SELECT
    d.id 'ID',
    d.dtdate 'Date',
    d.fld 'Field'
FROM
    maindata d
LEFT JOIN
    (
    SELECT
        d1.id 'ID',
        d1.dtdate 'Date',
        d1.fld 'Field'
    FROM
        maindata d1
    INNER JOIN
        keepremove kr ON
        (d1.fld = kr.toremove)
    INNER JOIN
        maindata d2 ON
        (d2.fld = d1.fld) AND
        (d2.dtdate = d1.dtdate) AND
        (d2.fld = kr.tokeep)
    GROUP BY
        d1.id,
        d1.dtdate,
        d1.fld
    ) sq ON
    (sq.id = d.id) AND
    (sq.date = d.dtdate) AND
    (sq.field = d.fld)
WHERE
    sq.id IS NULL