Faster way to delete rows with 0 value

J

Jayus03

New Member
Joined
Jul 21, 2015
Messages
5
Hi All,

I have over 200,000 rows of data in excel, with value in column D, I am currently using a macro to delete all rows with zero value in column D, but it is taking forever to finish (20+ minutes and still going), is there a way to make it run faster?

Sub Testin()


varCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False


SrcRange = Sheets("Sheet1").Range("D2", Range("D2").End(xlDown)).Select
With Selection
Selection.NumberFormat = "0"
.Value = .Value
End With


Dim myloop
For myloop = Range("D2").End(xlDown).Row To 1 Step -1
If Cells(myloop, 4).Value = 0 Then Rows(myloop).EntireRow.Delete
Next myloop
' need to revise to trim down on run time
MsgBox "Finished"


End Sub

Thank you!
 
Sort by date Sort by votes
Peter_SSs said:
Although you have a vast improvement, if you are looking for speed, you might also consider the following code.
With 100,000 rows of data, of which about 5% contained zeros, Eric's code took about 20 seconds on my machine.
For identical data, this code took 0.37 seconds.

Rich (BB code): 
Sub Del_Zero()
  Dim a, b
  Dim nc As Long, i As Long
 
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("D1", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = 0 Then b(i, 1) = 1
  Next i
  Application.ScreenUpdating = False
  With Range("A1").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    On Error Resume Next
    .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub
Click to expand...

Should also be a little bit quicker if the rows for deletion are sorted so that they are the bottom instead of the top.
 
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
footoo said:
Should also be a little bit quicker if the rows for deletion are sorted so that they are the bottom instead of the top.
Click to expand...
I have tested 4 different codes (2 deleting rows at the top and 2 deleting rows from the bottom) and obtained different results on different machines/Excel versions.
On my fairly new Win 10 laptop with Excel 2016 the code from post #6 here was faster than the other 3 codes tested by 8% to 18%.
On my much older desktop with Win 10 and Excel 2010 a different code was fastest (6% - 10%), but it also deleted rows from the top.

Do you have some particular code in mind that I could test with?
 
Upvote 0
I don’t have any particular code in mind – it’s just a matter of revising your code a bit to put the rows for deletion at the bottom.

Using your test data, any reduction in the run time would not, of course, be meaningful since you recorded 0.37 seconds only.
But it may depend upon the make up of the data – for instance, if there are many formulas on the sheet.

Several years ago, I did a test of deleting several thousand non-contiguous rows while retaining many more rows than those being deleted.
Using a loop, I stepped through the code and it became apparent that the time to delete each area was longer as the number of rows at the bottom increased - hence the reason for grouping rows fror deletion at the bottom rather than the top.
 
Upvote 0
Peter_SSs said:
Although you have a vast improvement, if you are looking for speed, you might also consider the following code.
With 100,000 rows of data, of which about 5% contained zeros, Eric's code took about 20 seconds on my machine.
For identical data, this code took 0.37 seconds.

Rich (BB code): 
Sub Del_Zero()
  Dim a, b
  Dim nc As Long, i As Long
 
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("D1", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = 0 Then b(i, 1) = 1
  Next i
  Application.ScreenUpdating = False
  With Range("A1").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    On Error Resume Next
    .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub
Click to expand...

I'm trying to figure out how to expand the range where the data set to look for zeros is in Col V, however I have data A:V that needs to adjust with the sort...feeling lost in how to go about that.
 
Upvote 0
Does this work?

Code: 
Sub Del_Zero()
  Dim a, b
  Dim nc As Long, i As Long
 
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("V1", Range("V" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = 0 Then b(i, 1) = 1
  Next i
  Application.ScreenUpdating = False
  With Range("A1").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    On Error Resume Next
    .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
sheetspread said:
Does this work?

Rich (BB code): 
Sub Del_Zero()
  Dim a, b
  Dim nc As Long, i As Long
 
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("V1", Range("V" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = 0 Then b(i, 1) = 1
  Next i
  Application.ScreenUpdating = False
  With Range("A1").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    On Error Resume Next
    .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub
Click to expand...

Unfortunately, no, as that (after I adjusted the ranges to V6 & A6, it killed headers & left zeros without fully going through col V to determine what to assign (1 or 0).

However I figured that if I simply added a second cell to the range in lieu of just "A1", defined the full range "A6:X6" it works PERFECTLY.
Code: 
[COLOR=#00008b]Sub[/COLOR] Del_Zero()
  [COLOR=darkblue]Dim[/COLOR] a, b
  [COLOR=darkblue]Dim[/COLOR] nc [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], i [COLOR=darkblue]As[/COLOR] Long
 
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("V6", Range("V" & Rows.Count).End(xlUp)).Value
  [COLOR=darkblue]ReDim[/COLOR] b(1 [COLOR=darkblue]To[/COLOR] [COLOR=darkblue]UBound[/COLOR](a), 1 [COLOR=darkblue]To[/COLOR] 1)
  [COLOR=darkblue]For[/COLOR] i = 1 [COLOR=darkblue]To[/COLOR] [COLOR=darkblue]UBound[/COLOR](a)
    [COLOR=darkblue]If[/COLOR] a(i, 1) = 0 [COLOR=darkblue]Then[/COLOR] b(i, 1) = 1
  [COLOR=darkblue]Next[/COLOR] i
  Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
  [COLOR=darkblue]With[/COLOR] Range("A6:X6").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
    .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
  [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
  Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
 
Upvote 0
I think this works too:

Code: 
Sub Del_Zero()
  Dim a, b
  Dim nc As Long, i As Long
 
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("V6", Range("V" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = 0 Then b(i, 1) = 1
  Next i
  Application.ScreenUpdating = False
  With Range("A6").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    On Error Resume Next
    .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub

But maybe the data sample I'm testing doesn't match yours (A6:X224 with headers in row 5)
 
Upvote 0
sheetspread said:
I think this works too:

Code: 
Sub Del_Zero()
  Dim a, b
  Dim nc As Long, i As Long
 
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("V6", Range("V" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = 0 Then b(i, 1) = 1
  Next i
  Application.ScreenUpdating = False
  With Range("A6").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    On Error Resume Next
    .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub

But maybe the data sample I'm testing doesn't match yours (A6:X224 with headers in row 5)
Click to expand...

Just tested on a data set of 10,000 rows of data, 6,355 zero values spread out throughout the data; your code was faster.

My adaptation: 0.96875 seconds
Your adaptation: .08125 seconds

Thank you Sir :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

Guinaba
  • Question Question
Tunning a VBA macro
Replies
1
Views
70
Skyybot
Skyybot
Guinaba
  • Solved
Copying range to table
2
Replies
12
Views
298
Alex Blakenburg
A
S
  • Question Question
Vba to search for a value in column A, if found enter specific text then delete the row
Replies
2
Views
217
StevenChin
S
I
  • Solved
Delete entire row based off cell value ignoring 2nd row
Replies
6
Views
340
ItalianPlatinum
I
C
  • Solved
VBA code for changes in cell and delete cell value
2
Replies
10
Views
248
cooleomter
C

Forum statistics

Threads
1,223,246
Messages
6,170,987
Members
452,373
Latest member
TimReeks

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top