How To Make This VBA Code Faster To Hide Upto 2200 Rows & Set Certain Rows at Specific Height If more than 60 Characters

B

bearwires

Board Regular
Joined
Mar 25, 2008
Messages
57
Office Version
  1. 365
Platform
  1. Windows
Can Excel Top Gun here help a rookie out and let me know if there are a better/faster way to perform the same action?
This code works, but its slow and can take around 3-4 minutes on a laptop with i7 12th Gen processor & 64Gb RAM.

The process is to hide the entire row if the respective cell in Column A is blank, then set the row height to 40 of any cells in column A where the text string is greater than 60 characters.

VBA Code: 
Sub CollateCOSHHSheets()

Dim r As Range, c As Range
Set r = Range("B5:B2208")
Application.ScreenUpdating = False
For Each c In r
If c.Value = "" Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next c

Dim lngLastRow As Long
    Dim lngLoopCtr As Long
    Application.ScreenUpdating = False
    lngLastRow = Range("A" & Rows.Count).End(xlUp).Row
    For lngLoopCtr = 1 To lngLastRow Step 1
        If Len(Cells(lngLoopCtr, "A")) > 60 Then
            Cells(lngLoopCtr, "A").RowHeight = 40
        End If
    Next lngLoopCtr
    Application.ScreenUpdating = True

End Sub
 
Sort by date Sort by votes
johnnyL said:
No response, so I have included the code I came up with that should be pretty close.

VBA Code: 
Sub Test()
'
    Dim ArrayRow                    As Long
    Dim LastRow                     As Long, StartRowColumnB    As Long
    Dim StartRowColumnA             As Long
    Dim RowOffset                   As Long
    Dim RangesToHide                As Range
    Dim RangesToIncreaseRowHeighth  As Range
    Dim InputArray                  As Variant
'
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
'
    LastRow = 2208                                                                                  ' <--- Set this to the last row to be used in column B, you may want to calculate this
    StartRowColumnB = 5                                                                             ' <--- Set this to the start row of data in column B
'
    InputArray = Range("B" & StartRowColumnB & ":B" & LastRow)                                      ' Load column B range values into 2D 1 based InputArray
    RowOffset = StartRowColumnB - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArray, 1) To UBound(InputArray, 1)                                   ' Loop through rows of InputArray
        If InputArray(ArrayRow, 1) = vbNullString Then                                              '   If cell is 'blank' then ...
            If Not RangesToHide Is Nothing Then                                                     '       If RangesToHide already has entries then ...
                Set RangesToHide = Union(RangesToHide, Range("B" & ArrayRow + RowOffset & "" & _
                        ":" & "B" & ArrayRow + RowOffset & ""))                                     '           Add the Range to hide to RangesToHide
            Else                                                                                    '       Else ...
                Set RangesToHide = Range("B" & ArrayRow + RowOffset & "" & ":" & "B" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to hide to RangesToHide
            End If
        End If
    Next                                                                                            ' Loop back
'
    RangesToHide.EntireRow.Hidden = True                                                            ' Hide all the RangesToHide rows in one swoop
'
' Column B rows are now hidden
'
' Set row heighths of remaining Column A entries to 40 if Length of column A entry is > 60 characters
'
'
    LastRow = Range("A" & Rows.Count).End(xlUp).Row                                                 '
    StartRowColumnA = Range("A" & 1).End(xlDown).Row                                                '
'
    InputArray = Range("A" & StartRowColumnA & ":A" & LastRow)
'
    RowOffset = StartRowColumnA - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArray, 1) To UBound(InputArray, 1)                                   ' Loop through rows of InputArray
        If Len(InputArray(ArrayRow, 1)) > 60 Then                                                   '   If length of cell is > 60 then ...
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow + RowOffset & "" & ":" & "A" & ArrayRow + RowOffset & ""))         '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow + RowOffset & "" & ":" & "A" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
        End If
    Next                                                                                            ' Loop back
'
    RangesToIncreaseRowHeighth.RowHeight = 40                                                       ' Increase all the row heights in one swoop
'
    Application.ScreenUpdating = True                                                               ' Turn ScreenUpdating back on
'
    MsgBox "Completed."                                                                             ' Let user know that script has completed
End Sub
Click to expand...
Holy Cow Johnny! This works great and it performs the operation almost instantly :oops:
Thanks so much for you help :love:
 
Upvote 0

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
johnnyL said:
No response, so I have included the code I came up with that should be pretty close.

VBA Code: 
Sub Test()
'
    Dim ArrayRow                    As Long
    Dim LastRow                     As Long, StartRowColumnB    As Long
    Dim StartRowColumnA             As Long
    Dim RowOffset                   As Long
    Dim RangesToHide                As Range
    Dim RangesToIncreaseRowHeighth  As Range
    Dim InputArray                  As Variant
'
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
'
    LastRow = 2208                                                                                  ' <--- Set this to the last row to be used in column B, you may want to calculate this
    StartRowColumnB = 5                                                                             ' <--- Set this to the start row of data in column B
'
    InputArray = Range("B" & StartRowColumnB & ":B" & LastRow)                                      ' Load column B range values into 2D 1 based InputArray
    RowOffset = StartRowColumnB - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArray, 1) To UBound(InputArray, 1)                                   ' Loop through rows of InputArray
        If InputArray(ArrayRow, 1) = vbNullString Then                                              '   If cell is 'blank' then ...
            If Not RangesToHide Is Nothing Then                                                     '       If RangesToHide already has entries then ...
                Set RangesToHide = Union(RangesToHide, Range("B" & ArrayRow + RowOffset & "" & _
                        ":" & "B" & ArrayRow + RowOffset & ""))                                     '           Add the Range to hide to RangesToHide
            Else                                                                                    '       Else ...
                Set RangesToHide = Range("B" & ArrayRow + RowOffset & "" & ":" & "B" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to hide to RangesToHide
            End If
        End If
    Next                                                                                            ' Loop back
'
    RangesToHide.EntireRow.Hidden = True                                                            ' Hide all the RangesToHide rows in one swoop
'
' Column B rows are now hidden
'
' Set row heighths of remaining Column A entries to 40 if Length of column A entry is > 60 characters
'
'
    LastRow = Range("A" & Rows.Count).End(xlUp).Row                                                 '
    StartRowColumnA = Range("A" & 1).End(xlDown).Row                                                '
'
    InputArray = Range("A" & StartRowColumnA & ":A" & LastRow)
'
    RowOffset = StartRowColumnA - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArray, 1) To UBound(InputArray, 1)                                   ' Loop through rows of InputArray
        If Len(InputArray(ArrayRow, 1)) > 60 Then                                                   '   If length of cell is > 60 then ...
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow + RowOffset & "" & ":" & "A" & ArrayRow + RowOffset & ""))         '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow + RowOffset & "" & ":" & "A" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
        End If
    Next                                                                                            ' Loop back
'
    RangesToIncreaseRowHeighth.RowHeight = 40                                                       ' Increase all the row heights in one swoop
'
    Application.ScreenUpdating = True                                                               ' Turn ScreenUpdating back on
'
    MsgBox "Completed."                                                                             ' Let user know that script has completed
End Sub
Click to expand...
Hi Johnny,

How could this code be amended to set the row height of "B33" to 40, as well as every row offset from B33 by 29 rows, upto the end of the data at Row 2208?
 
Upvote 0
VBA Code: 
Sub Test()
'
    Dim ArrayRow                    As Long
    Dim LastRow                     As Long, StartRowColumnB    As Long
    Dim StartRowColumnA             As Long
    Dim RowOffset                   As Long
    Dim RangesToHide                As Range
    Dim RangesToIncreaseRowHeighth  As Range
    Dim InputArray                  As Variant
'
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
'
    LastRow = 2208                                                                                  ' <--- Set this to the last row to be used in column B, you may want to calculate this
    StartRowColumnB = 5                                                                             ' <--- Set this to the start row of data in column B
'
    InputArray = Range("B" & StartRowColumnB & ":B" & LastRow)                                      ' Load column B range values into 2D 1 based InputArray
    RowOffset = StartRowColumnB - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArray, 1) To UBound(InputArray, 1)                                   ' Loop through rows of InputArray
        If InputArray(ArrayRow, 1) = vbNullString Then                                              '   If cell is 'blank' then ...
            If Not RangesToHide Is Nothing Then                                                     '       If RangesToHide already has entries then ...
                Set RangesToHide = Union(RangesToHide, Range("B" & ArrayRow + RowOffset & "" & _
                        ":" & "B" & ArrayRow + RowOffset & ""))                                     '           Add the Range to hide to RangesToHide
            Else                                                                                    '       Else ...
                Set RangesToHide = Range("B" & ArrayRow + RowOffset & "" & ":" & "B" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to hide to RangesToHide
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToHide Is Nothing Then RangesToHide.EntireRow.Hidden = True                        ' Hide all the RangesToHide rows in one swoop
'
'---------------------------------------------------------------------------------------------------
'
' Column B rows are now hidden
'
' Set row heighths of remaining Column A entries to 40 if Length of column A entry is > 60 characters
'
'
    LastRow = Range("A" & Rows.Count).End(xlUp).Row                                                 '
    StartRowColumnA = Range("A" & 1).End(xlDown).Row                                                '
'
    InputArray = Range("A" & StartRowColumnA & ":A" & LastRow)
'
    RowOffset = StartRowColumnA - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArray, 1) To UBound(InputArray, 1)                                   ' Loop through rows of InputArray
        If Len(InputArray(ArrayRow, 1)) > 60 Then                                                   '   If length of cell is > 60 then ...
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow + RowOffset & "" & ":" & "A" & ArrayRow + RowOffset & ""))         '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow + RowOffset & "" & ":" & "A" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToIncreaseRowHeighth Is Nothing Then RangesToIncreaseRowHeighth.RowHeight = 40     ' Increase all the row heights in one swoop
'
'---------------------------------------------------------------------------------------------------
'
    Set RangesToIncreaseRowHeighth = Nothing
'
    For ArrayRow = 33 To 2208 Step 29                                                               ' Loop through rows
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow & "" & ":" & "A" & ArrayRow & ""))                                 '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow & "" & ":" & "A" & _
                        ArrayRow & "")                                                              '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
    Next                                                                                            ' Loop back
'
    If Not RangesToIncreaseRowHeighth Is Nothing Then RangesToIncreaseRowHeighth.RowHeight = 40     ' Increase all the row heights in one swoop
'
'---------------------------------------------------------------------------------------------------
'
    Application.ScreenUpdating = True                                                               ' Turn ScreenUpdating back on
'
    MsgBox "Completed."                                                                             ' Let user know that script has completed
End Sub
 
Upvote 0
johnnyL said:
VBA Code: 
Sub Test()
'
    Dim ArrayRow                    As Long
    Dim LastRow                     As Long, StartRowColumnB    As Long
    Dim StartRowColumnA             As Long
    Dim RowOffset                   As Long
    Dim RangesToHide                As Range
    Dim RangesToIncreaseRowHeighth  As Range
    Dim InputArray                  As Variant
'
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
'
    LastRow = 2208                                                                                  ' <--- Set this to the last row to be used in column B, you may want to calculate this
    StartRowColumnB = 5                                                                             ' <--- Set this to the start row of data in column B
'
    InputArray = Range("B" & StartRowColumnB & ":B" & LastRow)                                      ' Load column B range values into 2D 1 based InputArray
    RowOffset = StartRowColumnB - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArray, 1) To UBound(InputArray, 1)                                   ' Loop through rows of InputArray
        If InputArray(ArrayRow, 1) = vbNullString Then                                              '   If cell is 'blank' then ...
            If Not RangesToHide Is Nothing Then                                                     '       If RangesToHide already has entries then ...
                Set RangesToHide = Union(RangesToHide, Range("B" & ArrayRow + RowOffset & "" & _
                        ":" & "B" & ArrayRow + RowOffset & ""))                                     '           Add the Range to hide to RangesToHide
            Else                                                                                    '       Else ...
                Set RangesToHide = Range("B" & ArrayRow + RowOffset & "" & ":" & "B" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to hide to RangesToHide
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToHide Is Nothing Then RangesToHide.EntireRow.Hidden = True                        ' Hide all the RangesToHide rows in one swoop
'
'---------------------------------------------------------------------------------------------------
'
' Column B rows are now hidden
'
' Set row heighths of remaining Column A entries to 40 if Length of column A entry is > 60 characters
'
'
    LastRow = Range("A" & Rows.Count).End(xlUp).Row                                                 '
    StartRowColumnA = Range("A" & 1).End(xlDown).Row                                                '
'
    InputArray = Range("A" & StartRowColumnA & ":A" & LastRow)
'
    RowOffset = StartRowColumnA - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArray, 1) To UBound(InputArray, 1)                                   ' Loop through rows of InputArray
        If Len(InputArray(ArrayRow, 1)) > 60 Then                                                   '   If length of cell is > 60 then ...
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow + RowOffset & "" & ":" & "A" & ArrayRow + RowOffset & ""))         '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow + RowOffset & "" & ":" & "A" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToIncreaseRowHeighth Is Nothing Then RangesToIncreaseRowHeighth.RowHeight = 40     ' Increase all the row heights in one swoop
'
'---------------------------------------------------------------------------------------------------
'
    Set RangesToIncreaseRowHeighth = Nothing
'
    For ArrayRow = 33 To 2208 Step 29                                                               ' Loop through rows
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow & "" & ":" & "A" & ArrayRow & ""))                                 '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow & "" & ":" & "A" & _
                        ArrayRow & "")                                                              '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
    Next                                                                                            ' Loop back
'
    If Not RangesToIncreaseRowHeighth Is Nothing Then RangesToIncreaseRowHeighth.RowHeight = 40     ' Increase all the row heights in one swoop
'
'---------------------------------------------------------------------------------------------------
'
    Application.ScreenUpdating = True                                                               ' Turn ScreenUpdating back on
'
    MsgBox "Completed."                                                                             ' Let user know that script has completed
End Sub
Click to expand...
Thanks Johnny, this works but there is an issue with the blank sheets when all rows in the offset range are set to 40.
I forgot these rows being changed has a signature image in column B, so when the row height is set, all the signatures on every sheet show because the associated row is now 40 high.

Can this be modified so that it only performs the row height change if there is a value in the previous cell in column B?
The cell before the signature box has text determined by an IF function. The true value of the IF function means the cell is "", and the false value of the IF function means there is text in the cell.

Therefore, if the row height is only set to 40 when the previous cell has text, then this would mean all blank sheets would stay completely hidden and only sheets with data would show.

i.e.
Set Row Height for Cells B33, B62, B91, B120, B149,........B2208 = 40, If the cell before it has a value (text string) -->B32, B61, B90, B119, B148........B2207 = "Text String"

But, If the cell before it has no text string value (has formula but blank), skip the row height change.

Hope that makes sense.

I really appreciate your help with this.
 
Upvote 0
Try this:

VBA Code: 
Sub TestV3()
'
    Dim ArrayRow                    As Long
    Dim LastRow                     As Long, StartRowColumnB    As Long
    Dim StartRowColumnA             As Long
    Dim RangesToHide                As Range
    Dim RangesToIncreaseRowHeighth  As Range
    Dim InputArrayA                 As Variant
    Dim InputArrayB                 As Variant
'
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
'
    LastRow = 2208                                                                                  ' <--- Set this to the last row to be used in column B, you may want to calculate this
    StartRowColumnB = 5                                                                             ' <--- Set this to the start row of data in column B
'
    InputArrayB = Range("B1:B" & LastRow)                                                           ' Load column B range values into 2D 1 based InputArray
'
    For ArrayRow = StartRowColumnB To LastRow                                                       ' Loop through rows of InputArrayB
        If InputArrayB(ArrayRow, 1) = vbNullString Then                                             '   If cell is 'blank' then ...
            If Not RangesToHide Is Nothing Then                                                     '       If RangesToHide already has entries then ...
                Set RangesToHide = Union(RangesToHide, Range("B" & ArrayRow & "" & _
                        ":" & "B" & ArrayRow & ""))                                                 '           Add the Range to hide to RangesToHide
            Else                                                                                    '       Else ...
                Set RangesToHide = Range("B" & ArrayRow & "" & ":" & "B" & _
                        ArrayRow & "")                                                              '           Save the Range to hide to RangesToHide
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToHide Is Nothing Then RangesToHide.EntireRow.Hidden = True                        ' Hide all the RangesToHide rows in one swoop
'
'---------------------------------------------------------------------------------------------------
'
' Column B rows are now hidden
'
' Set row heighths of remaining Column A entries to 40 if Length of column A entry is > 60 characters
'
'
    LastRow = Range("A" & Rows.Count).End(xlUp).Row                                                 '
    StartRowColumnA = Range("A" & 1).End(xlDown).Row                                                '
'
    InputArrayA = Range("A" & StartRowColumnA & ":A" & LastRow)                                     '
'
    RowOffset = StartRowColumnA - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArrayA, 1) To UBound(InputArrayA, 1)                                 ' Loop through rows of InputArrayA
        If Len(InputArrayA(ArrayRow, 1)) > 60 Then                                                   '   If length of cell is > 60 then ...
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow + RowOffset & "" & ":" & "A" & ArrayRow + RowOffset & ""))         '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow + RowOffset & "" & ":" & "A" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToIncreaseRowHeighth Is Nothing Then RangesToIncreaseRowHeighth.RowHeight = 40     ' Increase all the row heights in one swoop
'
'---------------------------------------------------------------------------------------------------
'
    Set RangesToIncreaseRowHeighth = Nothing
'
    For ArrayRow = 33 To 2208 Step 29                                                               ' Loop through rows
        If Len(InputArrayB(ArrayRow - 1, 1)) > 0 Then                                               '   If previous cell in column is not blank then ...
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow & "" & ":" & "A" & ArrayRow & ""))                                 '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow & "" & ":" & "A" & _
                        ArrayRow & "")                                                              '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToIncreaseRowHeighth Is Nothing Then RangesToIncreaseRowHeighth.RowHeight = 40     ' Increase all the row heights in one swoop
'
'---------------------------------------------------------------------------------------------------
'
    Application.ScreenUpdating = True                                                               ' Turn ScreenUpdating back on
'
    MsgBox "Completed."                                                                             ' Let user know that script has completed
End Sub
 
Upvote 0
Solution
johnnyL said:
Try this:

VBA Code: 
Sub TestV3()
'
    Dim ArrayRow                    As Long
    Dim LastRow                     As Long, StartRowColumnB    As Long
    Dim StartRowColumnA             As Long
    Dim RangesToHide                As Range
    Dim RangesToIncreaseRowHeighth  As Range
    Dim InputArrayA                 As Variant
    Dim InputArrayB                 As Variant
'
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
'
    LastRow = 2208                                                                                  ' <--- Set this to the last row to be used in column B, you may want to calculate this
    StartRowColumnB = 5                                                                             ' <--- Set this to the start row of data in column B
'
    InputArrayB = Range("B1:B" & LastRow)                                                           ' Load column B range values into 2D 1 based InputArray
'
    For ArrayRow = StartRowColumnB To LastRow                                                       ' Loop through rows of InputArrayB
        If InputArrayB(ArrayRow, 1) = vbNullString Then                                             '   If cell is 'blank' then ...
            If Not RangesToHide Is Nothing Then                                                     '       If RangesToHide already has entries then ...
                Set RangesToHide = Union(RangesToHide, Range("B" & ArrayRow & "" & _
                        ":" & "B" & ArrayRow & ""))                                                 '           Add the Range to hide to RangesToHide
            Else                                                                                    '       Else ...
                Set RangesToHide = Range("B" & ArrayRow & "" & ":" & "B" & _
                        ArrayRow & "")                                                              '           Save the Range to hide to RangesToHide
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToHide Is Nothing Then RangesToHide.EntireRow.Hidden = True                        ' Hide all the RangesToHide rows in one swoop
'
'---------------------------------------------------------------------------------------------------
'
' Column B rows are now hidden
'
' Set row heighths of remaining Column A entries to 40 if Length of column A entry is > 60 characters
'
'
    LastRow = Range("A" & Rows.Count).End(xlUp).Row                                                 '
    StartRowColumnA = Range("A" & 1).End(xlDown).Row                                                '
'
    InputArrayA = Range("A" & StartRowColumnA & ":A" & LastRow)                                     '
'
    RowOffset = StartRowColumnA - 1                                                                 ' Calculate the RowOffset for our addresses we will be converting
'
    For ArrayRow = LBound(InputArrayA, 1) To UBound(InputArrayA, 1)                                 ' Loop through rows of InputArrayA
        If Len(InputArrayA(ArrayRow, 1)) > 60 Then                                                   '   If length of cell is > 60 then ...
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow + RowOffset & "" & ":" & "A" & ArrayRow + RowOffset & ""))         '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow + RowOffset & "" & ":" & "A" & _
                        ArrayRow + RowOffset & "")                                                  '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToIncreaseRowHeighth Is Nothing Then RangesToIncreaseRowHeighth.RowHeight = 40     ' Increase all the row heights in one swoop
'
'---------------------------------------------------------------------------------------------------
'
    Set RangesToIncreaseRowHeighth = Nothing
'
    For ArrayRow = 33 To 2208 Step 29                                                               ' Loop through rows
        If Len(InputArrayB(ArrayRow - 1, 1)) > 0 Then                                               '   If previous cell in column is not blank then ...
            If Not RangesToIncreaseRowHeighth Is Nothing Then                                       '       If RangesToIncreaseRowHeighth already has entries then ...
                Set RangesToIncreaseRowHeighth = Union(RangesToIncreaseRowHeighth, Range("A" & _
                        ArrayRow & "" & ":" & "A" & ArrayRow & ""))                                 '           Add the Range to increase row height to RangesToIncreaseRowHeighth
            Else                                                                                    '       Else ...
                Set RangesToIncreaseRowHeighth = Range("A" & ArrayRow & "" & ":" & "A" & _
                        ArrayRow & "")                                                              '           Save the Range to increase row height to RangesToIncreaseRowHeighth
            End If
        End If
    Next                                                                                            ' Loop back
'
    If Not RangesToIncreaseRowHeighth Is Nothing Then RangesToIncreaseRowHeighth.RowHeight = 40     ' Increase all the row heights in one swoop
'
'---------------------------------------------------------------------------------------------------
'
    Application.ScreenUpdating = True                                                               ' Turn ScreenUpdating back on
'
    MsgBox "Completed."                                                                             ' Let user know that script has completed
End Sub
Click to expand...
Thank you so much Johnny, this works great.
Do you have any idea why even though all the lines get hidden and I can only see the sheets I need on the actual tab, when I goto print preview, all the hidden sheets are showing as a blank page. So I can see all 76 pages when I only need to see the pages which are not hidden?
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
VBA hide/unhide
Replies
2
Views
457
Cancyy
C
B
  • Solved
VBA to set row height not working
Replies
4
Views
1K
rollis13
rollis13
E
  • Solved
Quick VBA code to Hide Rows based on Cell Value
Replies
3
Views
519
Joe4
Joe4
O
  • Question Question
Somewhat basic UDFs work except that they return #VALUE! error after hiding rows with VBA.
Replies
2
Views
111
OaklandJim
O
PuntingJawa
  • Question Question
Exclude hidden rows when printing
2
Replies
15
Views
681
PuntingJawa
PuntingJawa

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,632
Latest member
jladair

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