Create Dynamic Outline with multiple levels based on Outline Hierarchy

[mrmmickle1]

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
	A	B	C	D	E	F
1	Organizational Order	Level from Top	Lvl 1	Lvl 2	Lvl 3	Lvl 4
2	1	0
3	1.1	1	1
4	1.1.1	2	1	2
5	1.1.2	2	1	2
6	1.1.3	2	1	2
7	1.2	1	1
8	1.2.1	2	1	2
9	1.2.1.1	3	1	2	3
10	1.2.1.1.1	4	1	2	3	4
11	1.2.1.1.2	4	1	2	3	4
12	1.2.1.2	3	1	2	3
13	1.2.1.3	3	1	2	3
14	1.2.1.3.1	4	1	2	3	4
15	1.2.1.3.2	4	1	2	3	4
16	1.2.1.3.3	4	1	2	3	4
17	1.2.2	2	1	2
18	1.2.2.1	3	1	2	3
19	1.2.2.1.1	4	1	2	3	4
20	1.2.2.1.2	4	1	2	3	4
21	1.2.2.1.3	4	1	2	3	4
22	1.2.2.1.4	4	1	2	3	4
23	1.2.2.1.5	4	1	2	3	4
24	1.2.2.1.6	4	1	2	3	4
25	1.2.2.1.7	4	1	2	3	4
26	1.2.2.1.8	4	1	2	3	4
27	1.2.2.2	3	1	2	3
28	1.2.2.2.1	4	1	2	3	4
29	1.2.2.2.2	4	1	2	3	4
30	1.2.2.2.3	4	1	2	3	4
31	1.2.2.2.4	4	1	2	3	4
32	1.2.2.2.5	4	1	2	3	4
Sheet2

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

[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.

 

[Andrew Poulsom]

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.

 

[mrmmickle1]

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....

=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.

 

[mrmmickle1]

Way Simpler than I was making it out to be......

[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]