Create Dynamic Outline with multiple levels based on Outline Hierarchy

mrmmickle1

Well-known Member
Joined
May 11, 2012
Messages
2,461
I'm trying to Outline an Organizational Hierarchy. I'm having trouble getting my code to work properly... It will work for the first two levels and then it fails. I was hoping that someone may have run into a similar issue in the past. While this example only goes 4 layers deep I would like to be able to achieve 7 layers as things can get more complex than what I have listed. If anyone has any suggestions or a complete answer that would be helpful I would much appreciate it. The idea is to have them roll up to one another... in the below example all columns that are labeled as Lvl 1, Lvl 2, Lvl 3 & Lvl 4 do not actually exist. I have just added this to help with clarification/visualization.

Raw Data:


Excel 2010
ABCDEF
1Organizational OrderLevel from TopLvl 1Lvl 2Lvl 3Lvl 4
210
31.111
41.1.1212
51.1.2212
61.1.3212
71.211
81.2.1212
91.2.1.13123
101.2.1.1.141234
111.2.1.1.241234
121.2.1.23123
131.2.1.33123
141.2.1.3.141234
151.2.1.3.241234
161.2.1.3.341234
171.2.2212
181.2.2.13123
191.2.2.1.141234
201.2.2.1.241234
211.2.2.1.341234
221.2.2.1.441234
231.2.2.1.541234
241.2.2.1.641234
251.2.2.1.741234
261.2.2.1.841234
271.2.2.23123
281.2.2.2.141234
291.2.2.2.241234
301.2.2.2.341234
311.2.2.2.441234
321.2.2.2.541234
Sheet2








Here is the code that I currently have.....


Code:
[COLOR=#0000cd]Sub[/COLOR] OutlineData()


    [COLOR=#0000cd]Dim[/COLOR] grpArr()     [COLOR=#0000cd] As Variant[/COLOR]
    [COLOR=#0000cd]Dim[/COLOR] grpTtl       [COLOR=#0000cd] As Integer[/COLOR]
    [COLOR=#0000cd]Dim[/COLOR] arrLp         [COLOR=#0000cd]As Integer[/COLOR]
    [COLOR=#0000cd]Dim [/COLOR]grpRowTop     [COLOR=#0000cd]As Long[/COLOR]
    [COLOR=#0000cd]Dim[/COLOR] grpRowBot     [COLOR=#0000cd]As Long[/COLOR]
   [COLOR=#0000cd] Dim[/COLOR] lRow          [COLOR=#0000cd]As Long[/COLOR]
    [COLOR=#0000cd]Dim[/COLOR] cycleLp       [COLOR=#0000cd]As Integer[/COLOR]


    lRow = Cells(Rows.Count, "B").End(xlUp).Row[COLOR=#008000] 'Get Last Row[/COLOR]
    grpTtl = Application.Max(Range("B2:B" & lRow)) [COLOR=#008000]'Get Max Level[/COLOR]
    
[COLOR=#008000]    'Set collapsable buttons adjacent to org level[/COLOR]
    Sheets("Sheet2").Outline.SummaryRow = xlAbove

[COLOR=#0000cd]    ReDim[/COLOR] grpArr(grpTtl)     [COLOR=#008000]'Create Array[/COLOR]
    
[COLOR=#008000]    'Update Array Values and set outlines[/COLOR]
 [COLOR=#0000ff]   For[/COLOR] arrLp = 0 [COLOR=#0000ff]To[/COLOR] grpTtl
    
         grpArr(arrLp) = arrLp
    
[COLOR=#0000ff]         Do[/COLOR]
            [COLOR=#0000ff]If [/COLOR]cycleLp = 0 [COLOR=#0000ff]Then[/COLOR]
               [COLOR=#0000ff]Set [/COLOR]fndItmTop = Sheets("Sheet2").Range("B2:B" & lRow).Find(grpArr(arrLp), , xlValues, , xlByRows, xlNext, False)
               grpRowTop = fndItmTop.Row + 1
[COLOR=#0000ff]            Else[/COLOR]
              [COLOR=#0000ff]  Set [/COLOR]fndItmTop = Sheets("Sheet2").Range("B" & grpRowBot + 2 & ":B" & lRow).Find(grpArr(arrLp), , xlValues, , xlByRows, xlNext, [COLOR=#0000ff]False[/COLOR])
              [COLOR=#0000ff]  If[/COLOR] fndItmTop [COLOR=#0000ff]Is Nothing Then[/COLOR]
                    grpRowTop = grpRowBot + 2
[COLOR=#0000ff]                Else[/COLOR]
                    grpRowTop = fndItmTop.Row + 1
[COLOR=#0000ff]                End If[/COLOR]
    
[COLOR=#0000ff]            End If[/COLOR]
            
         [COLOR=#0000ff]   Set[/COLOR] fndItmBot = Sheets("Sheet2").Range("B" & grpRowTop & ":B" & lRow).Find(grpArr(arrLp), , xlValues, , xlByRows, xlNext,[COLOR=#0000ff] False[/COLOR])
          [COLOR=#0000ff]  If[/COLOR] fndItmBot [COLOR=#0000ff]Is Nothing Then[/COLOR]
               grpRowBot = lRow
               grpDone = [COLOR=#0000ff]True[/COLOR]
[COLOR=#0000ff]            Else[/COLOR]
               grpRowBot = fndItmBot.Row - 1
[COLOR=#0000ff]            End If[/COLOR]
[COLOR=#008000]            'Group Rows[/COLOR]
            Rows(grpRowTop & ":" & grpRowBot).Rows.Group
            cycleLp = cycleLp + 1
         Loop Until grpDone = [COLOR=#0000ff]True[/COLOR]
[COLOR=#008000]         'Reset Counters[/COLOR]
         grpDone = [COLOR=#0000ff]False[/COLOR]
         cycleLp = 0
   [COLOR=#0000ff]  Next[/COLOR] arrLp
   
[COLOR=#0000ff]End Sub[/COLOR]

I appreciate any help someone can offer.
 
Last edited:

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Don't you just need to count the number of dots? All your Organisational Order data should be text. Some appear to be numbers as they are right aligned.
 
Upvote 0
It appears that after the first level I could count the dots. Should I just go down column A and check cells one at a time for the number of dots? and look for when the gap occurs.... i.e. the gap between dot count.

I think I'll use this formula to accomplish this....

Code:
=LEN(A2)-LEN(SUBSTITUTE(A2,".",""))

I think I may have been looking at this particular issue to long.... hahahaahah

Seems easy enough. I'll post back when I have the solution.
 
Upvote 0
Way Simpler than I was making it out to be......

Code:
[COLOR=#0000ff]Sub[/COLOR] OutlineData()

    [COLOR=#0000ff]Dim[/COLOR] grpTtl        [COLOR=#0000ff]   As Integer[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] LvlLp           [COLOR=#0000ff] As Integer[/COLOR]
 [COLOR=#0000ff]   Dim[/COLOR] lRow             [COLOR=#0000ff]As Long[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] IntLp         [COLOR=#0000ff]   As Integer[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] DotCount        [COLOR=#0000ff] As Integer[/COLOR]

    lRow = Cells(Rows.Count, "A").End(xlUp).Row [COLOR=#008000]'Get Last Row[/COLOR]
    grpTtl = Application.Max(Range("B2:B" & lRow)) [COLOR=#008000]'Get Max Level[/COLOR]
    ActiveSheet.Outline.SummaryRow = xlAbove [COLOR=#008000]'Set collapsable buttons adjacent to org level[/COLOR]
  
[COLOR=#008000]    'Outline Data[/COLOR]
   [COLOR=#0000ff] For [/COLOR]LvlLp = 0 [COLOR=#0000ff]To[/COLOR] grpTtl
        [COLOR=#0000ff] For[/COLOR] IntLp = 2 [COLOR=#0000ff]To[/COLOR] lRow
         DotCount = Len(Cells(IntLp, "A")) - Len(Replace(Cells(IntLp, "A"), ".", ""))
         [COLOR=#0000ff]   If [/COLOR]DotCount > LvlLp [COLOR=#0000ff]Then[/COLOR]
               Rows(IntLp).Rows.Group
[COLOR=#0000ff]            End If[/COLOR]
      [COLOR=#0000ff]  Next[/COLOR] IntLp
  [COLOR=#0000ff]   Next[/COLOR] LvlLp
   
[COLOR=#0000ff]End Sub[/COLOR]
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,524
Messages
6,179,304
Members
452,904
Latest member
CodeMasterX

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top