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?

• holroy: Is it common in VBA not to have indentation after Sub, or is that a formatting error when you posted question?
• Dan W: @holroy I'm no expert, but I have seen some people do it and some not. AFAIK the convention is to indent code within if statements, do and for loops etc, so that their start and end can be easily seen. The VBA Editor in Excel automatically inserts lines between subs and functions, so it is easy to visually see their start and end. Not indenting every line within a sub also gives you a little more room for code.
• ThunderFrame: I'd encourage you to indent any and all block types, including sub and function blocks. If you must preserve screen real estate, change your indenting to 2 spaces instead of 4 ( 2 is my preference, but some people like 4 - just be consistent). The indenting doesn't matter in this question because we can easily see its a single routine, but when you start having numerous routines, you'll be glad you indented. You could try SmartIndenter which will do all of the work, or look at RubberDuck 2.0 which plans to include SmartIndenter.
• Raystafarian: I'm confused - what does this do? It goes through rows looking for merged cells and sets the height to 15px and any rows without merged cells are set to 12.75?
• Dan W: @Raystafarian yeah that's all this sub does. Thanks for your answer below. It did the trick!

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.

• Dan W: Thanks @Raystafarian! It turned out to be the screen updated after every procedure. Adding Application.screenupdating = False and then switching it on again at the end reduced the time to 0.1sec. (The sheet has a bunch of other formatting and a few buttons). Thanks so much for your help!