-
1 Attachment(s)
Outline By Customer Name
-
I tried to use this code which I got help with a similar issue on before I posted:
I believe ExcelFox was my hero in this case:
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("Sheet1").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("Sheet1").UsedRange.Columns(5).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
-
-
As it turns out there was some kind of strange formatting on the file. It did not register the cells that I was visually seeing as blank to be blank (I hope this makes sense). I ended up copying the data to another sheet and restoring a format that would read blank cells.... This is the resulting code that works:
Code:
Sub Part1of4()
Columns("A:E").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Sub Part2of4()
Dim i As Integer, LastRow As Integer
'Group Cells in between blanks in column 5
LastRow = Cells(Rows.Count, 5).End(xlUp).row
For i = 2 To LastRow
If Not Left(Cells(i, 5), 3) = "" Then
Cells(i, 5).EntireRow.Group
End If
Next i
End Sub
Sub Part3of4()
'
' AlignUserGroupButtons Macro
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlLeft
End With
End Sub
Sub Part4of4()
'Collapses all Groups
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
End Sub
Sub RunSalesByCustomer()
Call Part1of4
Call Part2of4
Call Part3of4
Call Part4of4
End Sub
