Option Explicit
Sub TryThis()
Dim oWs As Worksheet, oSh As Worksheet
Dim lngRow As Long, lngCol
Dim rngUsed As Range, rngRow As Range, c As Range
Dim oOutline As Outline
Dim lngVisible As Long
Application.ScreenUpdating = False
Set oWs = ActiveSheet
lngRow = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
lngCol = Cells.Find("*", [a1], , , xlByColumns, xlPrevious).Column
Set rngUsed = Range(Cells(1, 1), Cells(lngRow, lngCol))
Set oOutline = oWs.Outline
oOutline.ShowLevels rowlevels:=8
lngVisible = rngUsed.Rows.SpecialCells(xlVisible).Count
oOutline.ShowLevels rowlevels:=1
If rngUsed.Rows.SpecialCells(xlVisible).Count = lngVisible Then
MsgBox "no groups found !"
oOutline.ShowLevels rowlevels:=8
Set oOutline = Nothing
Application.ScreenUpdating = True
Exit Sub
End If
For Each rngRow In rngUsed.Rows
If rngRow.Hidden Then Cells(rngRow.Row, lngCol + 1).Formula = "x"
Next rngRow
Sheets.Add After:=Sheets(Sheets.Count)
Set oSh = ActiveSheet
oWs.Activate
oOutline.ShowLevels rowlevels:=8
Set c = oSh.Cells(1, 1)
For Each rngRow In rngUsed.Rows
If Cells(rngRow.Row, lngCol + 1).Formula <> "x" Then
rngRow.Copy Destination:=c
Set c = c.Offset(1, 0)
End If
Next rngRow
Range(Cells(1, lngCol + 1), Cells(lngRow, lngCol + 1)).Clear
Set oOutline = Nothing
Application.ScreenUpdating = True
End Sub