Adding Lines based on Text in a Cell

Try this:

Sub InsertSectionRows()
    Dim lRow As Long
    Const iLeftChars As Integer = 3 'amend if necesssary
    
    On Error GoTo Terminate
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    With ActiveSheet
        For lRow = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            If .Cells(lRow, 1).Value <> "" And _
                .Cells(lRow - 1, 1).Value <> "" And _
                Left(.Cells(lRow, 1).Value, iLeftChars) <> Left(.Cells(lRow - 1, 1).Value, iLeftChars) Then Rows(lRow).EntireRow.Insert
        Next lRow
    End With
    
Terminate:
    If Err Then
        Debug.Print "Error", Err.code, Err.Description
        Err.Clear
    End If
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

It loops through your data in Column A from the bottom up, and for each row, compares the first n characters with the cell above (as long as both cells have something in them). If they are different, then a row is inserted. The number of characters which defines a match is controlled with parameter iLeftChars.

The Application stuff is to stop the screen flickering, and speed up performance, when applying to large datasets. The error handling makes sure that we reset the application stuff, even if an error happens, and that errors don't cause a horrible message to be displayed.

Make sense?

This code should do the trick.

Sub aTest()

Dim c As Range, ws As Worksheet
Set ws = Sheets("Sheet1")

For Each c In ws.Range("A3", "A" & ws.UsedRange.Rows.Count)
    
    If c <> ws.Cells(c.Row - 1, 1) And ws.Cells(c.Row - 1, 1) <> "" Then
    c.Rows.Insert Shift:=xlDown
    End If
Next c

End Sub

Or Olly's!