既然您已经展示了代码尝试，那么帮助您就更容易了
这是代码的修订版，其中包含注解的更改

Option Explicit

Sub InsertHeaderRow()

    Dim iRow As Long
     
    For iRow = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1 ' iterate backwards from column A last row to the third one (the 2nd one already has its headers in first row)
    
        If Cells(iRow, 1).Value <> Cells(iRow - 1, 1).Value Then ' compare column A current row cell content to the cell right above
        
            Rows(1).Copy
            Cells(iRow, 1).Insert Shift:=xlDown
        
        End If
    
    Next

End Sub

您可以通过以下方法改进上面的代码：首先收集需要新标题行的所有行，然后一次性插入新标题

Option Explicit

Sub InsertHeaderRow2()

    Dim headersRng As Range
    
    Dim iRow As Long
    For iRow = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1 ' iterate backwards from column A last row to the third one (the 2nd one already has its headers in firsst row)
    
        If Cells(iRow, 1).Value <> Cells(iRow - 1, 1).Value Then ' compare column A current row cell content to the cell right above
            ' update the "collection" of the cells that will need an inserted header
            If headersRng Is Nothing Then
                Set headersRng = Cells(iRow, 1)
            Else
                Set headersRng = Union(headersRng, Cells(iRow, 1))
            End If
        End If
    
    Next
        If Not headersRng Is Nothing Then ' if any cell need an inserted header
            headersRng.EntireRow.Insert Shift:=xlDown ' make room for headers
            Rows(1).Copy headersRng.Offset(-1) ' copy the header to the proper position
        End If
End Sub

最后，为了便于记录，下面是我发布的第一段代码
如果你不介意在数据的右边使用一个helper列，试试这个：

Option Explicit

Sub InsertHeaders()

    With Worksheets("Your Worksheet actual name")
        With .Range(.Cells(1, .Columns.Count).End(xlToLeft), .Cells(.Rows.Count, 1).End(xlUp))
            If .Rows.Count > 3 Then
                With .Resize(.Rows.Count - 2, 1).Offset(2, .Columns.Count)
                    .FormulaR1C1 = "=IF(RC[-5]<>R[-1]C[-5],1,"""")"
                    .Value = .Value
                End With
                
                    With .Resize(, .Columns.Count + 1)
                        .AutoFilter field:=.Columns.Count, Criteria1:="1"
                        With .Resize(.Rows.Count - 1).Offset(1)
                            If Application.Subtotal(103, .Resize(, 1)) > 1 Then
                                Dim headersRng As Range
                                    Set headersRng = .Resize(1).Offset(-1)
                                        With .SpecialCells(XlCellType.xlCellTypeVisible)
                                            .Parent.AutoFilterMode = False
                                            Dim iArea As Long
                                                For iArea = .Areas.Count To 1 Step -1
                                                    headersRng.Copy
                                                    .Areas(iArea).Rows(1).Insert Shift:=xlDown
                                                Next
                                        End With
                            End If
                        End With
                    End With
                    
                    .Resize(.Rows.Count - 2, 1).Offset(2, .Columns.Count).ClearContents
            End If
        End With
    End With

End Sub

标题行重复

Sub DuplicateHeaderRow()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' adjust!
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' table
    
    Dim hrg As Range: Set hrg = rg.Rows(1) ' header
    Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1) ' data
    
    Dim durg As Range, dCell As Range, c As Long, IsNotFirst As Boolean
    
    For Each dCell In drg.Columns(1).Cells
        If IsNotFirst Then
            If dCell.Value <> dCell.Offset(-1).Value Then
                If durg Is Nothing Then
                    Set durg = dCell
                Else
                    c = (c + 1) Mod 2
                    Set durg = Union(durg, dCell.Offset(, c))
                End If
            End If
        Else
            IsNotFirst = True
        End If
    Next dCell
    
    If Not durg Is Nothing Then
        durg.EntireRow.Insert xlShiftDown
        hrg.Copy Intersect(durg.EntireRow.Offset(-1), drg)
    End If
 
End Sub