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
'
'active sheet with groups
Set oWs = ActiveSheet
'used
lngRow = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
lngCol = Cells.Find("*", [a1], , , xlByColumns, xlPrevious).Column
Set rngUsed = Range(Cells(1, 1), Cells(lngRow, lngCol))
'
'chk Outline object
Set oOutline = oWs.Outline
'
'expand
oOutline.ShowLevels rowlevels:=8
lngVisible = rngUsed.Rows.SpecialCells(xlVisible).Count
'
'contract
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
'
'hidden
For Each rngRow In rngUsed.Rows
If rngRow.Hidden Then Cells(rngRow.Row, lngCol + 1).Formula = "x"
Next rngRow
'
'new sheet
Sheets.Add After:=Sheets(Sheets.Count)
Set oSh = ActiveSheet
oWs.Activate
'
'expand
oOutline.ShowLevels rowlevels:=8
'
'copy
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
'
'if unwanted "x"
Range(Cells(1, lngCol + 1), Cells(lngRow, lngCol + 1)).Clear
'ready
Set oOutline = Nothing
Application.ScreenUpdating = True
End Sub
|