Sub GroupRows()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim level As String
    Dim prevLevel As String
    Dim startRows As Object
    Dim levelKey As Variant

    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ws.Outline.ShowLevels RowLevels:=1 ' Resets existing grouping
    Application.ScreenUpdating = False

    Set startRows = CreateObject("Scripting.Dictionary")
    startRows.Add Key:=ws.Cells(2, 1).Value, Item:=2

    prevLevel = ws.Cells(2, 1).Value

    For i = 3 To lastRow + 1
        If i <= lastRow Then
            level = ws.Cells(i, 1).Value
        Else
            level = ""
        End If

        If level <> prevLevel Then
            For Each levelKey In startRows.Keys
                If InStr(level & ".", levelKey & ".") <> 1 Then
                    ws.Rows(startRows(levelKey) & ":" & i - 1).Group
                    startRows.Remove levelKey
                End If
            Next levelKey
            startRows.Add Key:=level, Item:=i
        End If

        prevLevel = level
    Next i

    Application.ScreenUpdating = True

End Sub