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!
ww
and notxx
. Are there value not inww
orxx
? \$\endgroup\$