Macro to delete rows if less then N instances works but is Slowww

[Tim Hanson]

The macro works well it deletes rows if there are less then N instances of a cells value in a column but I have large data sets and it can take along time to for it to execute

I was hoping someone knows how to seed this one up or has a faster method

Thank you

Sub DeleteLessThen_N()
Dim ws As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set ws = ThisWorkbook.Sheets("EdgeFile")

ws.Select
With ws.Range("B2", Cells(Rows.Count, 2).End(xlUp))
    .Value = Evaluate("=IF(COUNTIF(" & .Address & "," & .Address(1, 2) & ")<3,TRUE," & .Address & ")")
On Error Resume Next
    .SpecialCells(2, 4).EntireRow.Delete
End With

Range("A1").End(xlDown).Offset(1).Resize(ActiveSheet.UsedRange.Rows.Count).EntireRow.Delete
On Error GoTo 0

End Sub

 

[Luke M]

Can you sort the data? I would propose create helper column with row number (as constant). Insert formula to check if row needs to be deleted, sort on that column, delete unwanted rows (which are now in a single block), sort on row number, delete row numbers.

 

[Tim Hanson]

Hello luke, I forgot to say I am sorting but your other suggestions seem like a good plan of attack, I will give it a go

 

[shrivallabha]

Hi Tim,

Could you test below code which does the check mostly in the memory.

Public Sub DeleteRows()
Dim vSrc As Variant, vChk() As Variant
Const iCnt As Integer = 3 '\\ Set number of rows to be retained

'\\ Build up data in arrays so that we can process faster
With Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
  ReDim vChk(1 To .Rows.Count, 1 To 1)
  vSrc = .Value
End With

'\\ Create dictionary object for keeping count
With CreateObject("Scripting.Dictionary")
  For i = LBound(vSrc) To UBound(vSrc)
  If .Exists(vSrc(i, 1)) Then
  .Item(vSrc(i, 1)) = .Item(vSrc(i, 1)) + 1
  If .Item(vSrc(i, 1)) > iCnt Then
  Else
  vChk(i, 1) = 1
  End If
  Else
  .Add vSrc(i, 1), 1
  vChk(i, 1) = 1
  End If
  Next i
End With

'\\ Clean up the data using check done above
On Error Resume Next
With Range("E2:E" & Range("B" & Rows.Count).End(xlUp).Row)
  .Value = vChk
  .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  .Clear
End With

End Sub

 

[Tim Hanson]

Hello Shrivallabha, thanks for the response, sorry I tried to be clear but did not succeed.

I need to delete All rows where the total count of cells with the same value is less then N (say 3 for this case) and retain all rows where total count of cells with the same value is greater then N (or 3 in this case)

So if I have:

colA   colB
aaa    111
bbb    111
ccc     222
ddd    222
eee    222
fff      333
ggg    333
hhh    333
iii       333
jjj      444

I need:

colA   colB
ccc     222
ddd    222
eee    222
fff      333
ggg    333
hhh    333
iii       333

 

[NARAYANK991]

Hi Tim ,

Is it possible for you to upload either your original file , or one which has a large number of data rows , so that any improvement can be measured ?

If we can do the testing at our end , the solution will be posted faster , otherwise if the testing can only be done at your end , it is going to take a couple of iterations before you get the optimal solution.

Narayan

 

[shrivallabha]

Looks like I forgot my reading glasses. Here's revised code, see if it works faster.

Option Explicit
Public Sub DeleteRows()
Dim vSrc As Variant, vChk() As Variant
Const iCnt As Integer = 3 '\\ Set number of rows to be retained
Dim i As Long

'\\ Build up data in arrays so that we can process faster
With Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
  ReDim vChk(1 To .Rows.Count, 1 To 1)
  vSrc = .Value
End With

'\\ Create dictionary object for keeping count
With CreateObject("Scripting.Dictionary")
  For i = LBound(vSrc) To UBound(vSrc)
  If .Exists(vSrc(i, 1)) Then
  .Item(vSrc(i, 1)) = .Item(vSrc(i, 1)) + 1
  Else
  .Add vSrc(i, 1), 1
  End If
  Next i
  For i = LBound(vSrc) To UBound(vSrc)
  If .Item(vSrc(i, 1)) >= iCnt Then
  vChk(i, 1) = 1
  End If
  Next i
End With

'\\ Clean up the data using check done above
On Error Resume Next
With Range("E2:E" & Range("B" & Rows.Count).End(xlUp).Row)
  .Value = vChk
  .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  .Clear
End With

End Sub

On my computer it checked around 55000 rows data in 0.46875sec.

 

[Tim Hanson]

Hello Shrivallabha, the new code works great!! it is super fast and deletes all the proper rows.

Thank you!