Maintaining row height while inserting
I'm not sure what's happening on yours but with 10K rows it's doing 1 row per .000090625 seconds (&lt;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 &gt; 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 &lt; lastrow + 1
    If Cells(i, 1).MergeArea.Count &gt; 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 &gt; 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 &lt;&gt; 2 Then
       Cells(i, 1).RowHeight = 50
    Else: Cells(i, 1).RowHeight = 20
    End If
Next


But that's no faster.