speeding up loop

[Josephoo]

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.

'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.

 

[footoo]

https://www.rondebruin.nl/win/winfiles/MoreDeleteCode.txt

 

[steve the fish]

This should be quicker. Ive set it to do every sheet in the workbook so be careful!

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

 

[Peter_SSs]

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?

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

 

[Josephoo]

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!

 

[Michael M]

What about using

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

 

[Josephoo]

What about using

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!

 

[Michael M]

Then, untested

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

 

[Peter_SSs]

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.

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

 

[Josephoo]

OK, give this a try on a copy of your workbook.

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.