Zeilen einfügen

Sub sortieren()
Dim BisZeile As Integer
Dim BisSpalte As Integer
Dim AnzahlTS As Integer
BisZeile = Worksheets("Blechliste").Cells(Rows.Count, 2).End(xlUp).Row
BisSpalte = Worksheets("Blechliste").Cells(BisZeile, Columns.Count).End(xlToLeft).Column
AnzahlTS = Round((BisZeile - 5) / 2) + 5
'Worksheets("Blechliste").Range("N1").Value = AnzahlTS
Worksheets("Blechliste").Range(Cells(5, 1), Cells(BisZeile, BisSpalte)).Select
Selection.Sort Key1:=Range("J5"), Order1:=xlDescending, Key2:=Range("K5") _
, Order2:=xlDescending, Key3:=Range("D5"), Order3:=xlDescending, Header _
:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Worksheets("Blechliste").Cells(AnzahlTS, 2).EntireRow.Insert
Worksheets("Blechliste").Cells(AnzahlTS, 2).EntireRow.Insert
Worksheets("Blechliste").Range("A5").Select
Worksheets("Blechliste").Range("D5").Activate
End Sub

Nun möchte ich eine neue Zeile nach gleichen Werten bzw. zwischen ungleichen Werten einfügen.
Hab das mit:

Sub sortierenMat()
Dim Ende As Integer
Dim i As Integer
Ende = Worksheets("Blechliste").Cells(Rows.Count, 4).End(xlUp).Row
For i = 5 To Ende Step 1
If Worksheets("Blechliste").Cells(i, 4).Value = _
Worksheets("Blechliste").Cells(i - 1, 4).Value Then
Worksheets("Blechliste").Cells(i + 1, 4).EntireRow.Insert
End If
Next i
End Sub

Bringt mir aber nicht das gewünschte ergebnis, denn jetzt fügt er immer nach 2 gleichen werten eine Leerzeile ein. Wenn ich aber 3 oder 4 gleiche Werte in spalte 4 habe soll er erst nach 3 der 4 werten eine Leerzeile einfügen.
Ist das einigermaßen verständlich? Wer kann mir weiterhelfen.
Gruß