How to merge duplicate cell values in rows? My code is ignoring some of the duplicate values

Question

I'm trying to merge all contiguous duplicate cells in column D. I don't care about the formatting of the cells, and i don't need to sum any of the values. Was wondering what was wrong with my below code since not all of my duplicate cells are merging...Can only assume i'm skipping over them accidentally

with thisworkbook.sheets("sheet1") 
For i = StartRow + 1 To LastRow + 1
    
If Cells(i, 4) <> "" Then
    If Cells(i, 4) <> Cells(i - 1, 4) Then
        Application.DisplayAlerts = False
        Range(Cells(i - 2, 4), Cells(StartMerge, 4)).Merge
        Application.DisplayAlerts = True
        StartMerge = i
    End If
End If
Next i
End With

Answer 1

Close to your code: (updated; deleted If Cells(i, 4) <> "" Then)

Sub test1()
    With ThisWorkbook.Sheets("sheet1")
        StartRow = 1
        LastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
        
        StartMerge = StartRow + 1
        Application.DisplayAlerts = False
        For i = StartRow + 1 To LastRow
            If .Cells(i, 4) <> .Cells(i + 1, 4) Then
                .Range(.Cells(StartMerge, 4), .Cells(i, 4)).Merge
                StartMerge = i + 1
            End If
        Next i
        Application.DisplayAlerts = True
    End With
End Sub

Result: