Excel VBA routine to wrap text and set row height

Question

I have built a spreadsheet that at times requires to view "Notes" column so that all the text is visible, and sometimes so that all rows are the same height (15 works well). I wrote a routine called through click of a button and it works, but is slow (takes a few seconds for a table with 200 entries and could become longer if we have a couple of thousand records). I wonder if there was a better way to set row height. I base it on condition - if cell text is longer than 60 char, then wrap text and set row height. If less than 61 - set row height to 15.

Sub wrapText()

Dim targetRange As Range
Dim targetCell As Range
Dim w As Worksheet
Dim lastRow As Long


' avoid screen flicker

With Application
   .DisplayAlerts = False
   .ScreenUpdating = False


Set w = ActiveSheet
lastRow = w.UsedRange.Rows.Count


'Wrap cell text

Set targetRange = Range("G3:G" & lastRow)
For Each targetCell In targetRange.Cells
    If Not IsEmpty(targetCell.Value) Then
        If Len(targetCell.Value) > 60 Then
            targetCell.wrapText = True
            targetCell.EntireRow.AutoFit
        Else: targetCell.RowHeight = 15
        End If
    End If
Next targetCell

' This checks value of "O1" - I store 1 there if a custom filter is on

If Sheet1.Range("O1").Value = 0 Then  
    ActiveSheet.ListObjects("tblPatients").Range.AutoFilter Field:=6  
End If  
If Sheet1.Range("O1").Value = 1 Then
     ActiveSheet.ListObjects("tblPatients").Range.AutoFilter Field:=6, Criteria1:="="
End If

'\restore normal XL settings for application

    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

I wonder if there is something obvious how I could achieve the same but in a more efficient way? Thanks.

Answer 1

Try this version

Sub wrapText()

Dim targetRange As Range
Dim targetCell As Range
Dim w As Worksheet
Dim lastRow As Long


' avoid screen flicker

With Application
   .DisplayAlerts = False
   .ScreenUpdating = False


    Set w = ActiveSheet
    'lastRow = w.UsedRange.Rows.Count ' this is a quite bad and unstable idea, see below a better one


    'Wrap cell text
    Set targetRange = Range(w.Cells(1, 7), w.Cells(Rows.Count, 7).End(xlUp))

    With targetRange
        .Cells.RowHeight = 15 ' set all rows to 15 height

        For Each targetCell In .Cells
            If Not targetCell.Value = "" Then
                If Len(targetCell.Value) > 60 Then targetCell.wrapText = True
            End If
        Next targetCell

        .Cells.EntireRow.AutoFit ' autofit all rows in range
    End With


    ' This checks value of "O1" - I store 1 there if a custom filter is on


    Select Case Sheet1.Range("O1").Value ' is this another sheet?
        Case 0
            ActiveSheet.ListObjects("tblPatients").Range.AutoFilter Field:=6
        Case 1
            ActiveSheet.ListObjects("tblPatients").Range.AutoFilter Field:=6, Criteria1:="="
    End Select

    '\restore normal XL settings for application

    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

Comment in case of questions!