Check if consecutive rows have identical value, if not insert new row between them

Question

The task is to compare two consecutive rows, in the range from cell D1 to the last written cell in Column D.
If the value of a consecutive cell is equal to the value of the previous cell, i.e. D2=D1, go next, else insert a new row between the two values.

Sub Macro()

 'check rows
 
Dim a As Long
Dim b As Long, c As Long

a = Cells(Rows.Count, "D").End(xlUp).Row
For b = a To 2 Step -1
    c = b - 1

    If Cells(b, 4).Value = Cells(c, 4).Value Then
        If Cells(b, 4).Value <> Cells(c, 4).Value Then
            Rows("c").Select
            Selection.Insert Shift:=xlDown
        End If
    End If
    
Next b
    
End Sub

Answer 1

Sub InsertRows()
    Dim cl As Range
    With ActiveSheet
        Set cl = .Cells(.Rows.Count, "D").End(xlUp)
        Do Until cl.Row < 2
            Set cl = cl.Offset(-1)
            If cl.Value <> cl.Offset(1).Value Then cl.Offset(1).EntireRow.Insert
        Loop
    End With
End Sub

Side note. You can benefit from reading How to avoid using Select in Excel VBA