Add padding to top and bottom of cells

Question

I have a column with variable length text in each of the cells. I have written some code to add padding to the top and bottom of the cells. While the code works well it becomes quite slow when the number of rows is extremely large. Is there a better way of achieving the desired result without looping through each cell?

Function padCells()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

On Error GoTo resetApp
    
Dim rng As Range
Dim rw As Range

    Set rng = Selection
    
    With rng.Rows
        .WrapText = False
        .AutoFit
        .WrapText = True
        .AutoFit
    End With
    
    For Each rw In rng.Rows
        If rw.RowHeight >= 24 Then
            rw.RowHeight = rw.RowHeight + 10
        Else
            rw.RowHeight = 24
        End If
    Next

resetApp:
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Function

Answer 1

First of all I would replace this

With rng.Rows
    .WrapText = False
    .AutoFit
    .WrapText = True
    .AutoFit
End With

with just this

With rng.Rows
    .WrapText = True
    .AutoFit
End With

At least in my testing, the 2 lines that I've removed add no value and you get a minor performance gain if you remove them.

Things to avoid

In the following scenarios the method runs 20 to 40 times slower:

1. Page Breaks are on
2. Page View is not normal
3. Another worksheet is activated. I know it does not apply to your example because you are working with the current selection which always indicates the current active worksheet but you might decide to change that

All the above need to be addressed.

Other ways to achieve this

I don't think there is any other way.

Here is an idea that came up but it doesn't work:

1. Read the whole range into an array (Dim arr() As variant) using arr = rng.Value2
2. Duplicate the array with arrCopy = arr
3. Loop through each value and add a vbNewLine before and after each value inside arrCopy
4. Write back with rng.Value2 = arrCopy
5. AutoFit - this actually has padding because of the extra lines
6. Write back the original values with rng.Value2 = arr

This actually runs 60% faster than your method but unfortunately does not work mainly because when writing back the original values the padding is lost as Excel automatically autofits again. Also this won't work properly with formulas and not to mention you might not have permission to write to the range.

So, I don't think you can do this without looping through each row.

Actual Improvements

It turns out that if you minimize the book window or if you hide it then you actually gain about 30% in speed.

Final code

I would actually refactor this as a method that receives the range as a parameter so that you can reuse it in other scenarios as well. Also, I would check the sheet protection state to be sure the macro can run:

Option Explicit

Sub Main()
    On Error Resume Next
    PadCells Selection, 10
    If Err.Number <> 0 Then
        MsgBox "Pad failed: " & Err.Description, vbInformation, "Failed"
    End If
    On Error GoTo 0
End Sub

Public Sub PadCells(ByVal rng As Range, ByVal verticalPadding As Double)
    Const methodName As String = "PadCells"
    If rng Is Nothing Then
        Err.Raise 91, methodName, "Range not set"
    Else 'Check protection
        Dim ws As Worksheet: Set ws = rng.Worksheet
        '
        If ws.ProtectContents Then
            If Not ws.ProtectionMode Then
                Err.Raise 5, methodName, "Parent worksheet is macro protected"
            End If
        End If
    End If
    '
    'Store state as is as this method could be called from a higher
    ' method that still requires specific options when this method exits
    Dim drawingOn As Boolean: drawingOn = Application.ScreenUpdating
    Dim alertsOn As Boolean: alertsOn = Application.DisplayAlerts
    Dim eventsOn As Boolean: eventsOn = Application.EnableEvents
    Dim calcState As XlCalculation: calcState = Application.Calculation
    '
    'Turn state off
    If drawingOn Then Application.ScreenUpdating = False
    If alertsOn Then Application.DisplayAlerts = False
    If eventsOn Then Application.EnableEvents = False
    If calcState <> xlCalculationManual Then Application.Calculation = xlCalculationManual
    '
    'Guard against bad scenarios
    On Error GoTo RestoreState
    If ws.Name <> ActiveSheet.Name Then ws.Activate
    ws.DisplayPageBreaks = False
    With ws.Parent.Windows(1)
        Dim wView As XlWindowView: wView = .View
        If wView <> xlNormalView Then .View = xlNormalView
        .Visible = False '30% gain in speed!
    End With
    '
    Const maxRowHeight As Double = 409.5
    Dim rw As Range
    Dim newHeight As Double
    '
    With rng.Rows
        .WrapText = True
        .AutoFit
    End With
    For Each rw In rng.Rows
        If rw.RowHeight >= 24 Then
            newHeight = rw.RowHeight + verticalPadding
            If newHeight > maxRowHeight Then newHeight = maxRowHeight
            rw.RowHeight = newHeight
        Else
            rw.RowHeight = 24
        End If
    Next
RestoreState:
    With ws.Parent.Windows(1)
        If wView <> xlNormalView Then .View = wView
        .Visible = True
    End With
    If drawingOn Then Application.ScreenUpdating = True
    If alertsOn Then Application.DisplayAlerts = True
    If eventsOn Then Application.EnableEvents = True
    If calcState <> xlCalculationManual Then Application.Calculation = calcState
    '
    If Err.Number <> 0 Then Err.Raise Err.Number, methodName, Err.Description
End Sub

Edit #1

@Greedo had the idea in the comments to Union the ranges. Unfortunately that does not work well when rows of same height are not adjacent. However there is value in adding logic for adjacent rows of same height. Here is the updated method:

Public Sub PadCells(ByVal rng As Range, ByVal verticalPadding As Double)
    Const methodName As String = "PadCells"
    If rng Is Nothing Then
        Err.Raise 91, methodName, "Range not set"
    Else 'Check protection
        Dim ws As Worksheet: Set ws = rng.Worksheet
        '
        If ws.ProtectContents Then
            If Not ws.ProtectionMode Then
                Err.Raise 5, methodName, "Parent worksheet is macro protected"
            End If
        End If
    End If
    '
    'Store state as is as this method could be called from a higher
    ' method that still requires specific options when this method exits
    Dim drawingOn As Boolean: drawingOn = Application.ScreenUpdating
    Dim alertsOn As Boolean: alertsOn = Application.DisplayAlerts
    Dim eventsOn As Boolean: eventsOn = Application.EnableEvents
    Dim calcState As XlCalculation: calcState = Application.Calculation
    '
    'Turn state off
    If drawingOn Then Application.ScreenUpdating = False
    If alertsOn Then Application.DisplayAlerts = False
    If eventsOn Then Application.EnableEvents = False
    If calcState <> xlCalculationManual Then Application.Calculation = xlCalculationManual
    '
    'Guard against bad scenarios
    On Error GoTo RestoreState
    If ws.Name <> ActiveSheet.Name Then ws.Activate
    ws.DisplayPageBreaks = False
    With ws.Parent.Windows(1)
        Dim wView As XlWindowView: wView = .View
        If wView <> xlNormalView Then .View = xlNormalView
        .Visible = False '30% gain in speed!
    End With
    '
    Const maxRowHeight As Double = 409.5
    Dim rw As Range
    Dim newHeight As Double
    Dim startRow As Long
    Dim endRow As Long: endRow = 0
    Dim c As Long: c = rng.Rows.Count
    Dim i As Long
    '
    With rng.Rows
        .WrapText = True
        .AutoFit
    End With
    Do
        startRow = endRow + 1
        Set rw = rng.Rows(startRow)
        newHeight = rw.RowHeight
        For i = startRow + 1 To c
            If newHeight <> rng.Rows(i).RowHeight Then Exit For
        Next i
        If i > c Then
            endRow = c
        Else
            endRow = i - 1
        End If
        If startRow < endRow Then Set rw = rw.Resize(endRow - startRow + 1)
        If newHeight >= 24 Then
            newHeight = newHeight + verticalPadding
            If newHeight > maxRowHeight Then newHeight = maxRowHeight
            rw.RowHeight = newHeight
        Else
            rw.RowHeight = 24
        End If
    Loop Until endRow = c
RestoreState:
    With ws.Parent.Windows(1)
        If wView <> xlNormalView Then .View = wView
        .Visible = True
    End With
    If drawingOn Then Application.ScreenUpdating = True
    If alertsOn Then Application.DisplayAlerts = True
    If eventsOn Then Application.EnableEvents = True
    If calcState <> xlCalculationManual Then Application.Calculation = calcState
    '
    If Err.Number <> 0 Then Err.Raise Err.Number, methodName, Err.Description
End Sub