Maintaining row height while inserting

Question

I have a subroutine which re-formats cells after a heading is inserted into the document.

Most cells are 12.75 points high, whereas the headings are 15 points high.

When a heading (single line) is inserted, it pushes all of the other cells down, however the formatting does not move with them, so any headings below the inserted heading become 12.75 points high, while the cells above those headings become 15 points high.

Sub formatcell()
Dim sht1 As Worksheet
Set sht1 = ActiveSheet

Dim startRow As Integer
Dim endRow As Integer
Dim counter As Integer
Dim DoCell As Range
Dim start As Variant
Dim Finish As Variant

startRow = 16
endRow = FindLastRow(sht1)

'THIS BIT BELOW NEEDS TO BE SPED UP'
start = Timer                 'Start Timer'
counter = startRow
Do While counter < endRow + 1
    Set DoCell = sht1.Cells(counter, 1)
    Debug.Print "DoCell = " & DoCell.Address
    If DoCell.MergeArea.Count > 2 Then
        DoCell.RowHeight = 15
    Else
        DoCell.RowHeight = 12.75
    End If
    counter = counter + 1
Loop
Finish = Timer                            'End timer'
MsgBox = "Time Taken = " & Finish - start

End Sub

This uses the Range.MergeArea.Count method (which identifies the headings as they are 26 cells wide), however I need to move through all of the cells below Row 15 to the end of the sheet and format them all. The problem is that it takes roughly 0.06 seconds per row. This sheet can easily have over 100 rows which need formatting, which is then 6sec I need to wait, which is frustrating.

Is there any other method to do this? Could I give the heading cell a range name (i.e. Heading) when I insert it, and then lookup all cells with that range name?

Answer 1

I'm not sure what's happening on yours but with 10K rows it's doing 1 row per .000090625 seconds (<1 second total) -

Sub test()
Application.ScreenUpdating = False
Dim i As Integer
Dim firstrow As Integer
firstrow = 1
Dim lastrow As Integer
lastrow = 10000
'lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Start = Timer
For i = firstrow To lastrow
    If Cells(i, 1).MergeArea.Count > 1 Then
       Cells(i, 1).RowHeight = 15
    Else: Cells(i, 1).RowHeight = 12.5
    End If
Next
finish = Timer
MsgBox (finish - Start)
Application.ScreenUpdating = True
End Sub

Maybe try a for next loop instead of a do while loop and see if that changes anything?

Nope, I did a do while and it takes the same amount of time, maybe even less?

Do While i < lastrow + 1
    If Cells(i, 1).MergeArea.Count > 1 Then
       Cells(i, 1).RowHeight = 15
    Else: Cells(i, 1).RowHeight = 12.5
    End If
    i = i + 1
Loop

Try Application.ScreenUpdating = False, Application.Calculation = xlCalculationManual, Application.EnableEvents = False and maybe even Application.DisplayAlerts = False - see if those make a difference.

Even making all rows height 90 and running bottom up does 10K rows in less than a second -

For i = lastrow To firstrow Step -1
    If Cells(i, 1).MergeArea.Count > 1 Then
       Cells(i, 1).RowHeight = 30
    Else: Cells(i, 1).RowHeight = 10
    End If
Next

The only other way I could think of not looking for merged cells would be like this -

For i = lastrow To firstrow Step -1
    If Cells(i, 1).Offset(, 1).Column <> 2 Then
       Cells(i, 1).RowHeight = 50
    Else: Cells(i, 1).RowHeight = 20
    End If
Next

But that's no faster.