Very Long Loop

S

Smoakstack

Board Regular
Joined
Mar 28, 2011
Messages
79
I am looking for zeros and hiding column data to make table less cumbersome. here is my code:

Dim A as Range
Dim B as Range
Dim C as Range
Dim D as Range

For Each C In Sheets("Elevations").Range("M400:XX400")
If (C.Value = 0) Then
C.EntireColumn.Hidden = True
Else
C.EntireColumn.Hidden = False
End If
Next C

For Each B In Sheets("Elevations").Range("b9:b400")
If (B.Value = 0) Then
B.EntireRow.Hidden = True
Else
B.EntireRow.Hidden = False
End If
Next B


I have several sheets that these codes are running on, but it takes soo long. Is there a way to make it less of a wait using an array of some sort?
 
Sort by date Sort by votes
Hi,

Another way..

Code: 
Sub kTest()

    Dim Wkshts, i As Long
    Dim Addr
    
    Wkshts = Array("Sheet1", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9")
    Addr = Array("B9:B400", "M400:XX400", "D8:D37,D55:D78,D85:D90,D107:D109,D111:D120", _
                "D8:D43,D161:D184,D190:D213,D220:D225,D242:D244,D246:D255", _
                "D8:D37,D129:D152,D155:D178,D185:D190,D207:D209,D211:D220", _
                "D8:D22,D96:D119,D129:D134,D153:D155,D157:D160", _
                "D8:D22,D40:D57,D84:D86,D88:D97", _
                "D8:D31,D49:D66,D93:D95")
    
    Application.ScreenUpdating = False
    For i = LBound(Wkshts) To UBound(Wkshts)
        If i = 0 Then
            HideCells Wkshts(i), Addr(i), True
            HideCells Wkshts(i), Addr(i + 1), False
        Else
            HideCells Wkshts(i), Addr(i + 1), True
        End If
    Next
    Application.ScreenUpdating = True

End Sub
Sub HideCells(ByVal wksName As String, ByVal rngAddress As String, ByVal HideRow As Boolean)
    
    Dim strAddress  As String
    Dim lngSU       As Long
    
    lngSU = Application.ScreenUpdating
    Application.ScreenUpdating = False
    
    With Worksheets(CStr(wksName))
        On Error Resume Next
        .Range(CStr(rngAddress)).Replace "0", "", 1
        strAddress = .Range(CStr(rngAddress)).SpecialCells(4).Address(0, 0)
        With .Range(CStr(strAddress))
            .Value = 0
            If HideRow Then
                .EntireRow.Hidden = 1
            Else
                .EntireColumn.Hidden = 1
            End If
        End With
        On Error GoTo 0
    End With
    Application.ScreenUpdating = lngSU
    
End Sub

HTH
 
Upvote 0

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Dim Wkshts, i As Long
Dim Addr

Wkshts = Array("Sheet1", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9")
Addr = Array("B9:B400", "M400:XX400", "D8:D37,D55:D78,D85:D90,D107:D109,D111:D120", _
"D8:D43,D161:D184,D190:D213,D220:D225,D242:D244,D246:D255", _
"D8:D37,D129:D152,D155:D178,D185:D190,D207:D209,D211:D220", _
"D8:D22,D96:D119,D129:D134,D153:D155,D157:D160", _
"D8:D22,D40:D57,D84:D86,D88:D97", _
"D8:D31,D49:D66,D93:D95")

Application.ScreenUpdating = False
For i = LBound(Wkshts) To UBound(Wkshts)
If i = 0 Then
HideCells Wkshts(i), Addr(i), True
HideCells Wkshts(i), Addr(i + 1), False
Else
HideCells Wkshts(i), Addr(i + 1), True
End If
Next
Application.ScreenUpdating = True

SubScript out of range

 
Upvote 0
Try:

Code: 
Public Sub Smoakstack()
Dim rng             As Range, _
    i               As Long, _
    shtarr(2 To 30) As Range
    
Set shtarr(2) = Sheets("ACM Estimate").Range("D8:D37")
Set shtarr(3) = Sheets("ACM Estimate").Range("D55:D78")
Set shtarr(4) = Sheets("ACM Estimate").Range("D85:D90")
Set shtarr(5) = Sheets("ACM Estimate").Range("D107:D109")
Set shtarr(6) = Sheets("ACM Estimate").Range("D111:D120")
Set shtarr(7) = Sheets("Foam Estimate").Range("D8:D43")
Set shtarr(8) = Sheets("Foam Estimate").Range("D161:D184")
Set shtarr(9) = Sheets("Foam Estimate").Range("D190:D213")
Set shtarr(10) = Sheets("Foam Estimate").Range("D220:D225")
Set shtarr(11) = Sheets("Foam Estimate").Range("D242:D244")
Set shtarr(12) = Sheets("Foam Estimate").Range("D246:D255")
Set shtarr(13) = Sheets("Single Skin Estimate").Range("D8:D37")
Set shtarr(14) = Sheets("Single Skin Estimate").Range("D129:D152")
Set shtarr(15) = Sheets("Single Skin Estimate").Range("D155:D178")
Set shtarr(16) = Sheets("Single Skin Estimate").Range("D185:D190")
Set shtarr(17) = Sheets("Single Skin Estimate").Range("D207:D209")
Set shtarr(18) = Sheets("Single Skin Estimate").Range("D211:D220")
Set shtarr(19) = Sheets("SSMR Estimate").Range("D8:D22")
Set shtarr(20) = Sheets("SSMR Estimate").Range("D96:D119")
Set shtarr(21) = Sheets("SSMR Estimate").Range("D129:D134")
Set shtarr(22) = Sheets("SSMR Estimate").Range("D153:D155")
Set shtarr(23) = Sheets("SSMR Estimate").Range("D157:D160")
Set shtarr(24) = Sheets("Louver Estimate").Range("D8:D22")
Set shtarr(25) = Sheets("Louver Estimate").Range("D40:D57")
Set shtarr(26) = Sheets("Louver Estimate").Range("D84:D86")
Set shtarr(27) = Sheets("Louver Estimate").Range("D88:D97")
Set shtarr(28) = Sheets("Window Estimate").Range("D8:D31")
Set shtarr(29) = Sheets("Window Estimate").Range("D49:D66")
Set shrarr(30) = Sheets("Window Estimate").Range("D93:D95")
Application.ScreenUpdating = False
With Sheets("Sheet1")
    .rows("1:" & rows.Count).Hidden = False
    With .Range("B9:B400")
        Set rng = .Find("", LookIn:=xlValues, LookAt:=xlWhole)
        If Not rng Is Nothing Then
            Do
                rng.EntireRow.Hidden = True
                Set rng = .FindNext(rng)
            Loop While Not rng Is Nothing
        End If
    End With
    Set rng = Nothing
End With
With Sheets("Sheet1")
    With .Range("M400:XX400")
        Set rng = .Find("0", LookIn:=xlValues, LookAt:=xlWhole)
        If Not rng Is Nothing Then
            Do
                rng.EntireColumn.Hidden = True
                Set rng = .FindNext(rng)
            Loop While Not rng Is Nothing
        End If
    End With
    Set rng = Nothing
End With
For i = 2 To 30
    shtarr(i).Parent.rows("1:" & rows.Count).Hidden = False
        With shtarr(i)
            Set rng = .Find("0", LookIn:=xlValues, LookAt:=xlWhole)
            If Not rng Is Nothing Then
                Do
                    rng.EntireRow.Hidden = True
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing
            End If
        End With
    Set rng = Nothing
Next i
Application.ScreenUpdating = True
End Sub
 
Upvote 0
ok...renamed sheet names and still wont work. It will not hide any rows or columns. As of right now, with the code I have, the time has been cut drastcially. I only have to wait about 15-25 seconds compared to what it used to be of around 90-120 seconds.
 
Upvote 0
mr Kowz - I did that, hides the numbers in my elevations page fine, but not in my other sheets. Code runs fine, but does not hide the rows.
 
Upvote 0
Try this out - it was resetting the visible rows each time the code looped.

Code: 
Public Sub Smoakstack()
Dim rng             As Range, _
    i               As Long, _
    shtarr(2 To 30) As Range
    
Set shtarr(2) = Sheets("ACM Estimate").Range("D8:D37")
Set shtarr(3) = Sheets("ACM Estimate").Range("D55:D78")
Set shtarr(4) = Sheets("ACM Estimate").Range("D85:D90")
Set shtarr(5) = Sheets("ACM Estimate").Range("D107:D109")
Set shtarr(6) = Sheets("ACM Estimate").Range("D111:D120")
Set shtarr(7) = Sheets("Foam Estimate").Range("D8:D43")
Set shtarr(8) = Sheets("Foam Estimate").Range("D161:D184")
Set shtarr(9) = Sheets("Foam Estimate").Range("D190:D213")
Set shtarr(10) = Sheets("Foam Estimate").Range("D220:D225")
Set shtarr(11) = Sheets("Foam Estimate").Range("D242:D244")
Set shtarr(12) = Sheets("Foam Estimate").Range("D246:D255")
Set shtarr(13) = Sheets("Single Skin Estimate").Range("D8:D37")
Set shtarr(14) = Sheets("Single Skin Estimate").Range("D129:D152")
Set shtarr(15) = Sheets("Single Skin Estimate").Range("D155:D178")
Set shtarr(16) = Sheets("Single Skin Estimate").Range("D185:D190")
Set shtarr(17) = Sheets("Single Skin Estimate").Range("D207:D209")
Set shtarr(18) = Sheets("Single Skin Estimate").Range("D211:D220")
Set shtarr(19) = Sheets("SSMR Estimate").Range("D8:D22")
Set shtarr(20) = Sheets("SSMR Estimate").Range("D96:D119")
Set shtarr(21) = Sheets("SSMR Estimate").Range("D129:D134")
Set shtarr(22) = Sheets("SSMR Estimate").Range("D153:D155")
Set shtarr(23) = Sheets("SSMR Estimate").Range("D157:D160")
Set shtarr(24) = Sheets("Louver Estimate").Range("D8:D22")
Set shtarr(25) = Sheets("Louver Estimate").Range("D40:D57")
Set shtarr(26) = Sheets("Louver Estimate").Range("D84:D86")
Set shtarr(27) = Sheets("Louver Estimate").Range("D88:D97")
Set shtarr(28) = Sheets("Window Estimate").Range("D8:D31")
Set shtarr(29) = Sheets("Window Estimate").Range("D49:D66")
Set shrarr(30) = Sheets("Window Estimate").Range("D93:D95")
Application.ScreenUpdating = False
With Sheets("Sheet1")
    .rows("1:" & rows.Count).Hidden = False
    With .Range("B9:B400")
        Set rng = .Find("", LookIn:=xlValues, LookAt:=xlWhole)
        If Not rng Is Nothing Then
            Do
                rng.EntireRow.Hidden = True
                Set rng = .FindNext(rng)
            Loop While Not rng Is Nothing
        End If
    End With
    Set rng = Nothing
End With
With Sheets("Sheet1")
    With .Range("M400:XX400")
        Set rng = .Find("0", LookIn:=xlValues, LookAt:=xlWhole)
        If Not rng Is Nothing Then
            Do
                rng.EntireColumn.Hidden = True
                Set rng = .FindNext(rng)
            Loop While Not rng Is Nothing
        End If
    End With
    Set rng = Nothing
End With
Sheets("ACM Estimate").rows("1:" & rows.Count).Hidden = False
Sheets("Foam Estimate").rows("1:" & rows.Count).Hidden = False
Sheets("Single Skin Estimate").rows("1:" & rows.Count).Hidden = False
Sheets("SSMR Estimate").rows("1:" & rows.Count).Hidden = False
Sheets("Louver Estimate").rows("1:" & rows.Count).Hidden = False
Sheets("Window Estimate").rows("1:" & rows.Count).Hidden = False
For i = 2 To 30
        With shtarr(i)
            Set rng = .Find("0", LookIn:=xlValues, LookAt:=xlWhole)
            If Not rng Is Nothing Then
                Do
                    rng.EntireRow.Hidden = True
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing
            End If
        End With
    Set rng = Nothing
Next i
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Sheets("ACM Estimate").Rows("1:" & Rows.Count).Hidden = False
Sheets("Foam Estimate").Rows("1:" & Rows.Count).Hidden = False
Sheets("Single Skin Estimate").Rows("1:" & Rows.Count).Hidden = False
Sheets("SSMR Estimate").Rows("1:" & Rows.Count).Hidden = False
Sheets("Louver Estimate").Rows("1:" & Rows.Count).Hidden = False
Sheets("Window Estimate").Rows("1:" & Rows.Count).Hidden = False
For i = 2 To 30
With shtarr(i)
Set rng = .Find("0", LookIn:=xlValues, LookAt:=xlWhole)
If Not rng Is Nothing Then
Do
rng.EntireRow.Hidden = True
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing
End If
End With
Next i
End Sub

Application or object defined error
 
Upvote 0
Could it be from text in those ranges (Merged cells)? I have this thing broken down by labor, material, and other indirect costs?
 
Upvote 0
Most likely. Get rid of any merged cells you have. Merged cells and VBA go together about as good as oil and water.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
VBA - Hide Columns and Copy to a New Workbook
Replies
2
Views
234
CLAZGRE
C
C
  • Solved
VBA to find current month and year - Hide all others
Replies
3
Views
343
kevin9999
K
N
  • Solved
Move entire row based on expiration date
2
Replies
17
Views
225
rollis13
rollis13
S
  • Solved
VBA: Am I double-calling a Sub given nested If statements? Or other inefficiencies?
Replies
8
Views
249
dreid1011
dreid1011
B
  • Solved
Getting Macros to run automatically
Replies
3
Views
209
mumps
mumps

Forum statistics

Threads
1,215,025
Messages
6,122,732
Members
449,093
Latest member
Mnur

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