Try this
Code:
Sub Consolidator()
Dim obj As Range
'Since there is a possibility that there are already Outlines made in the used range, we'd want to ensure it is removed
On Error Resume Next
Do Until Err.Number <> 0
Worksheets("Data").UsedRange.Rows.Ungroup'This is where we remove the outlining
Loop
Err.Clear: On Error GoTo 0: On Error GoTo -1'Clear up and reset the error handling
For Each obj In Worksheets("Data").UsedRange.Columns(3).Cells.SpecialCells(xlCellTypeBlanks)'We use the specialcells method and pick only the blank cells, and then we loop through each blank cell
If Not IsEmpty(obj.Offset(2)) Then'If the cell 2 rows below the blank cell is not empty, then that means there are at least 2 rows to be grouped, in which case End(xlDown) will take use to the last row for that section
obj.Parent.Range(obj.Offset(1), obj.Offset(1).End(xlDown)).Rows.Group' so the section of the range that we want to group starts from the first cell below the blank cell, all the way down to the last cell in that group before the next blank, which can be located using End(xlDown) because there are at least 2 rows
Else
obj.Offset(1).Rows.Group'If the cell 2 rows below the blank cell is empty, we can assume that the section to be grouped has only 1 row, so we just group that row
End If
Next obj
End Sub
where "Data" is the name of the sheet where you have the data to be outlined. Change as suited.
Bookmarks