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

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
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

I
  • Question Question
Unable to run VBA code
Replies
6
Views
141
RoryA
RoryA
C
  • Solved
VBA - Hide Columns and Copy to a New Workbook
Replies
2
Views
394
CLAZGRE
C
H
  • Solved
Replace a character string with other characters in column "K"
2
Replies
18
Views
483
harzer
H
I
  • Solved
Code moves worksheets columns to the left thus not showing column A
Replies
5
Views
202
Peter_SSs
Peter_SSs
I
  • Question Question
Opening worksheet in another workbook advice
Replies
1
Views
179
ipbr21054
I

Forum statistics

Threads
1,224,590
Messages
6,179,763
Members
452,940
Latest member
rootytrip

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