asked on

Auto Outline Dataset in Excel

I am wanting to create an Auto outline macro in Excel for a data set. See the dataset in Sheet1 of the attached file. I want the code to be able to got through that dataset and each time it "reads" the word "Total", group the rows above it. An example of the dataset is in Sheet1 and an example of the desired output is in Sheet2.

Let know if any addtional clarification is needed.

Any takers?

Thanks,
EE-Example.xlsm

nutsch

This macro should work

Thomas

Sub AutoOutline_Total_Lines()
Dim cl As range, rng As range, intIndent As Long, i As Long
Dim rowStart As Long
Dim lastRow As Long 'define variables

application.ScreenUpdating = False

lastRow = range("A" & Rows.Count).End(xlUp).Row 'get last row

With ActiveSheet.Outline
    .AutomaticStyles = False
    .SummaryRow = xlBelow
    .SummaryColumn = xlRight
End With

rowStart = 7

For i = 2 To lastRow
    If Cells(i, "B") = "Total" Then
        Rows(rowStart & ":" & i - 1).Group
        rowStart = i + 1
    End If
Next

application.ScreenUpdating = True

End Sub

Open in new window

ASKER CERTIFIED SOLUTION

nutsch

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

ScriptAddict

If you have formulas then you can use the auto outline feature. Excel uses the formula's to create the auto outline. That said I don't believe that an auto outline is going to work for your purposes unless you have formula's built into your spreadsheet.

If you are going to use just text data/totals, then you will need to just use standard vba code.

I've tossed together this VBA code block that should do what you want. It is designed to start grouping on row eight.

Sub Total()
ptr = 8
Nextnt:
   nt = Cells.Find(What:="Total", After:=Cells(ptr, 1), LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Row
    If nt < ptr Then GoTo Done
    Range(Cells(ptr, 1), Cells(nt - 1, 1)).Select
    Selection.Rows.Group
    ptr = nt + 1
GoTo Nextnt
Done:
End Sub

Open in new window

ctownsen80

ASKER

Worked Like a Charm! Thank you very much.