VBA Automatic Outlining - Half way there

[dannyok90]

Hi all, ?

I found this code online and its almost exactly what i need.

Sub AutoGroupBOM()
    'Define Variables
    Dim StartCell As Range 'This defines the highest level of assembly, usually 1, and must be the top leftmost cell of concern for outlining, its our starting point for grouping'
    Dim StartRow As Integer 'This defines the starting row to beging grouping, based on the row we define from StartCell'
    Dim LevelCol As Integer 'This is the column that defines the assembly level we're basing our grouping on'
    Dim LastRow As Integer 'This is the last row in the sheet that contains information we're grouping'
    Dim CurrentLevel As Integer 'iterative counter'
    Dim i As Integer
    Dim j As Integer

    Application.ScreenUpdating = False 'Turns off screen updating while running.

    'Prompts user to select the starting row. It MUST be the highest level of assembly and also the top left cell of the range you want to group/outline"
    Set StartCell = Application.InputBox("Select top left cell for highest assembly level", Type:=8)
    StartRow = StartCell.Row
    LevelCol = StartCell.Column
    LastRow = ActiveSheet.UsedRange.Rows.Count

    'Remove any pre-existing outlining on worksheet, or you're gonna have 99 problems and an outline ain't 1
    Cells.ClearOutline

    'Walk down the bom lines and group items until you reach the end of populated cells in the assembly level column
    For i = StartRow To LastRow
        CurrentLevel = Cells(i, LevelCol)
        Rows(i).Select
        For j = 1 To CurrentLevel - 1
            Selection.Rows.Group
        Next j
    Next i

    Application.ScreenUpdating = True 'Turns on screen updating when done.

End Sub

Basically i need to edit the code so it suits my needs but as ever pretty rubbish at VBA. (see table below)

When i select yes in Column C and it turns the row into a "group header row" id like the lines associated with that group to outline automatically, the code above is almost there but im not sure what to change to get it to understand my numbering system and i think i need to use some kind of active cell command. hoping someone can help me out

Thanks ,Dan

this is the formula in the b column
=IF($C5="Yes",$A5,IF(ISERROR(VALUE(SUBSTITUTE(OFFSET(B5,-1,0,1,1),".",""))),"0.1",IF(ISERROR(FIND("`",SUBSTITUTE(OFFSET(B5,-1,0,1,1),".","`",1))),OFFSET(B5,-1,0,1,1)&".1",LEFT(OFFSET(B5,-1,0,1,1),FIND("`",SUBSTITUTE(OFFSET(B5,-1,0,1,1),".","`",1)))&IF(ISERROR(FIND("`",SUBSTITUTE(OFFSET(B5,-1,0,1,1),".","`",2))),VALUE(RIGHT(OFFSET(B5,-1,0,1,1),LEN(OFFSET(B5,-1,0,1,1))-FIND("`",SUBSTITUTE(OFFSET(B5,-1,0,1,1),".","`",1))))+1,VALUE(MID(OFFSET(B5,-1,0,1,1),FIND("`",SUBSTITUTE(OFFSET(B5,-1,0,1,1),".","`",1))+1,(FIND("`",SUBSTITUTE(OFFSET(B5,-1,0,1,1),".","`",2))-FIND("`",SUBSTITUTE(OFFSET(B5,-1,0,1,1),".","`",1))-1)))+1))))

	A (Hidden Helper)	B	C	D
1		Material Group	Group
2	1	1	Yes
3	=IF($C5="Yes",LARGE(A4,1)+1,INT(B5))	1.1
4	=IF($C6="Yes",LARGE($A$4:$A5,1)+1,INT(B6))	1.2
5	1	1.3
6	2	2	Yes
7	2	2.1
8	2	2.2

 

[Worf]

Hi

Sub Dan()
Dim st%, i%, LR%, pos, yes()
pos = 0
LR = Range("b" & Rows.count).End(xlUp).Row
st = 2
i = 0
Cells.ClearOutline
Do
    i = i + 1
    pos = Evaluate("=MATCH(FALSE,ISBLANK(C" & st & ":C" & LR & "),0)")
    If IsError(pos) Then Exit Do
    ReDim Preserve yes(i)
    yes(i) = st + pos - 1           ' where the yes word is
    st = st + pos
Loop While st < LR
ReDim Preserve yes(UBound(yes) + 1)
yes(UBound(yes)) = LR + 1
For i = LBound(yes) + 1 To UBound(yes) - 1
    Rows(CStr(yes(i) + 1) & ":" & CStr(yes(i + 1) - 1)).Group
Next
End Sub

 

[jocker_boy]

Hello,
Is there any possibilty to adjust this code to outline until level 4, based on column "B" values.

Outline.xlsm
	A	B
1		LEN
2	1	1
3	1.1	3
4	1.2	3
5	1.3	3
6	1.3.1	5
7	1.3.1.1	7
8	1.3.1.2	7
9	1.3.2	5
10	1.2	3
11	2	1
12	2.1	3
13	2.2	3
14	2.2.1	5
Sheet1

Cell Formulas
Range	Formula
B2:B14	B2	=LEN(A2)

Many Thanks.

GM