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

[bearwires]

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.

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

 

[johnnyL]

You have the range set to cells in the B column. Should that be the A column?

 

[bearwires]

You have the range set to cells in the B column. Should that be the A column?

My mistake Johnny, it hides blank rows based on empty cells in column B, then sets the height to 40 for any cell in column A where characters exceed 60

 

[johnnyL]

Do you have formulas that result to "" in column B?

 

[bearwires]

Do you have formulas that result to "" in column B?

Yes, both column A & column B have formulae which equate to "" for the true part of the IF function.

e.g

Column A

=IF($B8="","","Material")

Column B

=IF($B8="","",HLOOKUP($B8,'COSHH ASSESSMENTS'!$B$3:$CW$101,'COSHH ASSESSMENTS'!$CX$4,FALSE))

 

[johnnyL]

Sorry, one more question. I was hoping someone else would have chimed in because I am under the weather, but since noone else has chimed in, are the last row of column B and column A the same initially?

 

[johnnyL]

No response, so I have included the code I came up with that should be pretty close.

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

 

[kevin9999]

Another option (if you don't mind grouping the hidden rows together that is)

Option Explicit
Sub bearwires()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
    Dim ws As Worksheet
    Dim lRow As Long, lCol As Long, i As Long, a, b
    Dim r As Range
    
    Set ws = Worksheets("Sheet1")   '<<< Change to suit
    lRow = ws.Range("A:B").Find("*", , xlFormulas, , 1, 2).Row
    lCol = Cells.Find("*", , xlFormulas, , 2, 2).Column + 1
    
    a = ws.Range("B5:B" & lRow).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If a(i, 1) = "" Then b(i, 1) = 1
    Next i
    
    Cells(5, lCol).Resize(UBound(a)) = b
    i = WorksheetFunction.Sum(Columns(lCol))
    
    If i > 0 Then
        ws.Range(ws.Cells(5, 1), ws.Cells(lRow, lCol)).Sort Key1:=ws.Cells(5, lCol), order1:=1, Header:=2
        ws.Cells(5, lCol).Resize(i).EntireRow.Hidden = True
        ws.Columns(lCol).ClearContents
    End If
    
    For Each r In ws.Range("A5:A" & lRow)
        If Len(r) > 60 Then r.EntireRow.RowHeight = 40
    Next r
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub

 

[bearwires]

Sorry, one more question. I was hoping someone else would have chimed in because I am under the weather, but since noone else has chimed in, are the last row of column B and column A the same initially?

Sorry Johnny, I was watching Top Gun

 

[bebo021999]

It tooks immediately with 10,000 rows.
Hope it's faster (am I Tom Cruise?)
Employ another column ZZ (or any column that available), then delete it at the end.

Option Explicit
Sub CollateCOSHHSheets()
Dim lr&, i&, rng, rng2
Application.ScreenUpdating = False
lr = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row ' last used row
rng = Range("A1:B" & lr).Value ' read value into array
With Range("ZZ1:ZZ" & lr) ' employ column ZZ temporarily (or any helper column that available)
    .ClearContents
    .RowHeight = Rows(Rows.Count).RowHeight ' set all rows to defaul height
    rng2 = .Value
    For i = 1 To lr
        If Len(rng(i, 1)) >= 60 And rng(i, 2) <> "" Then rng2(i, 1) = "#N/A"
    Next
    .Value = rng2
    .SpecialCells(xlCellTypeConstants, xlErrors).RowHeight = 40
    .ClearContents
End With
Range("B1:B" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
Application.ScreenUpdating = True
End Sub