speeding up loop

Josephoo

New Member
Joined
Dec 7, 2015
Messages
22
Hi everyone

I have a loop that is already working. I was just thinking if there is a way to select all the cells that is zero and deleting it at one go instead of sorting it using a loop 1 by 1 by vba. this have to be done in vba as this is just part of the code in a very long line of codes.

the issue is because there are 3000 cells to evaluate. multiply that with 50 tabs that its cycling. that is a good 150,000 cells to check 1 by 1. the whole process takes me a few hours just to evaluate.

Code:
'delete empty rows
Dim LastRow as long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For r = LastRow To 1 Step -1
If Cells(r, 1) = 0 Then
Rows(r).Delete
End If
Next r

What this code does is that it will eliminate the zero values rows and consolidate all the known cells for further data manipulation.
would be great if someone can point me in the right direction.

Thanks heaps.
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
This should be quicker. Ive set it to do every sheet in the workbook so be careful!

Code:
Dim sh As Worksheet, lastrow As Long, arr, i As Long, rng As Range

For Each sh In ThisWorkbook.Worksheets
    With sh
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastrow > 1 Then
            arr = .Range("A1:A" & lastrow)
            For i = LBound(arr) To UBound(arr)
                If Not IsEmpty(arr(i, 1)) And arr(i, 1) = 0 Then
                    If Not rng Is Nothing Then
                        Set rng = Union(rng, .Range("A" & i))
                    Else
                        Set rng = .Range("A" & i)
                    End If
                End If
            Next
            If Not rng Is Nothing Then rng.EntireRow.Delete Shift:=xlUp
            Erase arr
            Set rng = Nothing
        End If
    End With
Next
 
Upvote 0
This should be even quicker. This one only acts on the active sheet though. I have assumed the sheet has a heading row. If not, please advise.
If you want it extended to other sheets, is it all sheets in the workbook or just specific sheets?

BTW, if it is to be applied to multiple tabs, do they all have the same number of columns of data? If so, what is the last column in each tab with data?

Code:
Sub Delete_Rows()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  a = Range("A2", Range("A" & 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
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub
 
Upvote 0
Thanks for the help. Thats very helpful. So basically the workbook have alot of sheets and each sheet have a unique name. there is a master sheet with raw data. all the sheets with unique names has exactly the same format. What i did was that i basically loop thru looking for empty values and then once its done i move on the the next sheet. in VBA i have the following:

sub program()

sheet 1()
Sheet 2()

end sub

So it actually call each sheet and re run the codes over and over again thats all. all the sheets have formula that draws from a master sheet that have raw data. essentially, the master sheet data -> sheets data(sorter) and then i just sort of delete the rows for further data manipulation.

If you have any idea how this can be further speed up, I'm definitely up for learning more!

Thanks man!
 
Upvote 0
What about using

Code:
Sub MM1()
  With Range("A1", Cells(Rows.Count, "A").End(xlUp))
    .Replace 0, "#N/A", xlWhole, , False, , False, False
    Columns("A").SpecialCells(xlConstants, xlErrors).EntireRow.Delete
  End With
End Sub
 
Upvote 0
What about using

Code:
Sub MM1()
  With Range("A1", Cells(Rows.Count, "A").End(xlUp))
    .Replace 0, "#N/A", xlWhole, , False, , False, False
    Columns("A").SpecialCells(xlConstants, xlErrors).EntireRow.Delete
  End With
End Sub

i think it works awesome for values. But My cells are all coded with formula like this. --> "=IF($I3<>$B$1,0,RawData!B2)"
what this does is that it checks col I and try to match with Cell B1. if if the same it will show a value if not zero. maybe i could get it to show NA and then it will just delete accordingly. Let me play around with the col as well as the rest too.

Edit: okay doesnt work with formula. let me think it thru how this should be done.

Peter: Last col is till J all cols have formula build into it. its for specific sheets thou its like 50sheets out of 53 sheets etc. all sheets are identical with same col, forumla and pointing to master raw data. they just have different criteria to only display certain values base on which "company" thats all.

steve and footoo: i need abit of time to try it out and update u guys. Thanks for the help! very interesting solutions.



Thanks people!
 
Last edited:
Upvote 0
Then, untested

Code:
Sub MM1()
  With Range("A1", Cells(Rows.Count, "A").End(xlUp))
    .Replace 0, "#N/A", xlWhole, , False, , False, False
    Columns("A").SpecialCells(xlformulas, xlErrors).EntireRow.Delete
  End With
End Sub
 
Upvote 0
Peter: Last col is till J all cols have formula build into it. its for specific sheets thou its like 50sheets out of 53 sheets etc. all sheets are identical with same col,
OK, give this a try on a copy of your workbook.

Code:
Sub Delete_Rows_v2()
  Dim ws As Worksheet
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long, AppCalc As Long
  
  AppCalc = Application.Calculation
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  nc = 11
  For Each ws In Worksheets
    Select Case ws.Name
      Case "Summary", "Report", "Special Cases" '<- List names of sheets you do NOT want processed
      
      Case Else '< This will do the following code on all other sheets
        k = 0
        With ws
          a = .Range("A2", .Range("A" & .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
              k = k + 1
            End If
          Next i
          If k > 0 Then
            With .Range("A2").Resize(UBound(a), nc)
              .Columns(nc).Value = b
              .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
              .Resize(k).EntireRow.Delete
            End With
          End If
        End With
    End Select
  Next ws
  Application.Calculation = AppCalc
  Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
OK, give this a try on a copy of your workbook.

Code:
Sub Delete_Rows_v2()
  Dim ws As Worksheet
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long, AppCalc As Long
  
  AppCalc = Application.Calculation
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  nc = 11
  For Each ws In Worksheets
    Select Case ws.Name
      Case "Summary", "Report", "Special Cases" '<- List names of sheets you do NOT want processed
      
      Case Else '< This will do the following code on all other sheets
        k = 0
        With ws
          a = .Range("A2", .Range("A" & .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
              k = k + 1
            End If
          Next i
          If k > 0 Then
            With .Range("A2").Resize(UBound(a), nc)
              .Columns(nc).Value = b
              .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
              .Resize(k).EntireRow.Delete
            End With
          End If
        End With
    End Select
  Next ws
  Application.Calculation = AppCalc
  Application.ScreenUpdating = True
End Sub

Thank you sir! I think it works every fast and very well. managed to cut down my timing from 3hrs to 15mins. its very interesting how you implemented it.
 
Upvote 0

Forum statistics

Threads
1,213,490
Messages
6,113,957
Members
448,535
Latest member
alrossman

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