VBA code to copy the heading and above subtotal groups - vba

Question

I have been trying to create a macro for copying the header and insert above all the subtotal groups. So all the subtotal groups will have a heading. I tried the below macro but it is not working.
Sub header()
Rows("1:1").Select
Selection.Copy
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "P"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "Total" Then
.Cells(R+1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub

Answer 1

Try the following. There are several tweaks:
1) I fixed the indenting. A matter of taste perhaps, but I find code hard to read if not logically indented.
2) I replaced the first two lines by Rows(1).Copy. There is no reason to select something in order to copy it (and 1 as an index is more idiomatic than "1:1")
3) The act of inserting the row completes the copy-paste operation. I thus recopied the header row after the insert operation. This fixes your actual problem
4) The final copy in the loop leaves Excel still looking for somewhere to paste the header row. Application.CutCopyMode = False addresses that.
Sub header()
Rows(1).Copy
Dim s As Range
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "P"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "Total" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
Rows(1).Copy
End If
Next R
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub