PDA

View Full Version : Macro an Outline based on value o:



dinostatic
08-18-2011, 01:31 AM
Hi,
First I'd like to apologize in advance for my "noob-ness," in all honesty I don't know a whole lot about VBA, but that's why I came here to seek help (:

Is there any way I can make a macro that automatically creates an outline based on a cell's value in that row? I'm working with excel 2003, and I have a whole lot of data that's been imported in a "tree like" hierarchy. It's color coded, but the auto-outline feature doesn't seem to outline it quite right. There is a column called Level that indicates the level in the tree of the item from 0 to 8. Is there a way I can use this, or the color of the row, to automatically group items and create an outline?

Any help would be appreciated. Thank you very much.

Bob Phillips
08-18-2011, 01:42 AM
Can you post you workbook, preferably with an example of how it should look.

dinostatic
08-18-2011, 03:03 AM
Here is an example of what I would like it to look like.
The fact is it took me a long time to set this up, and I'd like to find a way to macro it and make it much easier.

Bob Phillips
08-18-2011, 08:36 AM
Try this



Public Function SetOutlines()
Dim vecCIs As Variant
Dim Lastrow As Long
Dim i As Long

vecCIs = Array(xlColorIndexNone, 15, 20, 37, 47, 0)
With ActiveSheet

Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

Call OutlineRows(ActiveSheet, 3, Lastrow, vecCIs, 1)
End With
End Function

Private Function OutlineRows( _
ByRef sh As Worksheet, _
ByRef Currentrow As Long, _
ByVal Lastrow As Long, _
ByVal CIs As Variant, _
ByVal ThisCI As Long)
Dim i As Long

With sh

For i = Currentrow To Lastrow

Do Until .Cells(i, "A").Interior.ColorIndex = CIs(ThisCI - 1) Or _
i + 1 > Lastrow

i = i + 1
If .Cells(i, "A").Interior.ColorIndex = CIs(ThisCI + 1) Then

Call OutlineRows(sh, i, Lastrow, CIs, ThisCI + 1)
End If
Loop

If Currentrow = 3 Then Exit Function

If i <= Lastrow Then sh.Rows(Currentrow).Resize(i - Currentrow).Rows.Group

If .Cells(i, "A").Interior.ColorIndex = CIs(ThisCI - 1) Then

Currentrow = i
Exit Function
End If
Next i
End With
End Function