Delete rows based on search with empty cells in between groupings

In the working steps of my calculations I have ended up with a list which has been spread out with several empty rows in between groups of entries. Each entry needs to stand along from the rest, and they will later get condensed back together by deleting the empty rows. However at the point I am at, I need a macro which will treat each cluster sepeartely from each other and do a search to see if all of the values in column S are the same for that cluster (they are dates). What I need is if all of the values of S for that cluster are the same, then the rows that contain that data are deleted and the macro skips down the empty cells to the next cluster and repeats.


To put it another way, I need a macro that will look at column S, starting at S2, and search each group of rows with data as a range and search to see if they are all repeats. If so, the macro will delete these rows and skip down the empty cells in row S to the next rows with data, select that range, and search/delete again. It is important that the macro only looks at each group instead of the entire column because it is possible and allowed for the different groups to have the same data as the other groups, just not within the independent group itself.

Any help here will be really appreciated, I am nearly at the end of a long project in developing this tool for my boss and this is the last macro that I can not figure out how to write.

Try:

Sub YourBossOwesMeLunch()
Dim ws As Worksheet:    Set ws = Sheets("Sheet1")
Dim LR As Long, strRow As Long, miniLR As Long, sCell As Long, FinalRow As Long
Dim rng As Range, iFind As Range, icell As Range, myrng As Range
Dim iDelete As Boolean

Application.ScreenUpdating = False
LR = ws.Range("S" & Rows.Count).End(xlUp).Row

strRow = 2

Do Until strRow >= LR
    miniLR = ws.Range("S" & strRow).End(xlDown).Row
    Set rng = ws.Range("S" & strRow, "S" & miniLR)
        For Each icell In rng
            If icell.Row = miniLR Then
                Set myrng = ws.Range("S" & strRow, "S" & miniLR - 1)
            ElseIf icell.Row = strRow Then
                Set myrng = ws.Range("S" & strRow + 1, "S" & miniLR)
            Else
                Set myrng = Union(Range("S" & strRow, "S" & icell.Row - 1), Range("S" & icell.Row + 1, "S" & miniLR))
            End If
            Set iFind = myrng.Find(What:=icell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            
            If iFind Is Nothing Then
                iDelete = True
                Exit For
            End If
        Next icell
        If iDelete = True Then
            rng.EntireRow.Interior.ColorIndex = 3
        End If
    strRow = ws.Range("S" & miniLR + 1).End(xlDown).Row
    iDelete = False
Loop

For sCell = LR To 2 Step -1
    If ws.Range("S" & sCell).Interior.ColorIndex = 3 Then
        ws.Range("S" & sCell).EntireRow.Delete Shift:=xlUp
    End If
Next sCell

If IsEmpty(ws.Range("S2")) Then
    FinalRow = ws.Range("S2").End(xlDown).Row
    ws.Range("S2:S" & FinalRow - 1).EntireRow.Delete Shift:=xlUp
End If

Application.ScreenUpdating = True

End Sub

stnkynts, I wasn't able to get this to work because the lines "Dim LR As Long, strRow As Long, miniLR As Long, sCell As Long, FinalRow As Long" and "ws.Range("S" & sCell).EntireRow.Delete Shift:=xlUp" came back with an error.

If this doesn't work, need to see your data in col.S.

Sub test()
    Dim myAreas As Areas, myArea As Range, x As Range
    Set myAreas = Range("s2", Range("s" & Rows.Count) _
        .End(xlUp)).SpecialCells(2, 1).Areas
    For Each myArea In myAreas
        If Application.CountIf(myArea, myArea(1).Value) = myArea.Count Then
            If x Is Nothing Then
                Set x = myArea.EntireRow
            Else
                Set x = Union(x, myArea.EntireRow)
            End If
        End If
    Next
    If Not x Is Nothing Then x.Delete
End Sub

jindon, this worked fantastically. Thank you very much.