Sub RowGroup()
    Dim rn As Range, rn_ob As Range, lv As String, sd As Object, lst As Object, sh As Worksheet, wsh As Worksheet, n As Integer, y
    Set sd = CreateObject("Scripting.Dictionary")
    Set lst = CreateObject("Scripting.Dictionary")
    Set wsh = ActiveSheet
    Set rn_ob = wsh.UsedRange.Rows
    For Each sh In ActiveWorkbook.Worksheets
        lst.Add sh.Name, sh.Name
    Next
    For Each rn In rn_ob
        If rn.Rows.OutlineLevel = 2 Then
            lv = rn.Value2(1, 1)
            If Not sd.Exists(lv) Then
                sd.Add lv, rn
            Else
                Set sd(lv) = Application.Union(sd(lv), rn)
            End If
        ElseIf rn.Rows.OutlineLevel > 2 Then
            Set sd(lv) = Application.Union(sd(lv), rn)
        End If
    Next
    For Each y In sd
        lv = y
        If lst.Exists(lv) Then
            n = 1
            Do
                lv = y
                lv = lv & n
                n = n + 1
            Loop Until Not lst.Exists(lv)
        End If
        Sheets.Add.Name = lv
        sd(y).Copy Destination:=Worksheets(lv).Range("A1")
    Next
End Sub