I have a hierarchical list of items in an Excel worksheet and want to create a macro to group each row based on a cell value that gives the level of indention. The data looks like this:
Index Level Name
1 1 Assembly 1
2 2 Sub-assembly 1
3 2 Sub-assembly 2
3 3 Sub-sub-assembly 1
3 3 Sub-sub-assembly 2
4 2 Sub-assembly 3After the macro runs, the level 2 rows would be grouped one level (i.e. the equivalent of selecting the row and pressing Alt+Shift+Right Arrow, and the level 3 rows would be grouped two levels.
12 Answers
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 SubI searched for a macro to group rows based on an index like that:
1
1
1
2
2
2
2
3
3
3
To do that, I used your macro and changed it a little:
Sub AutoGroupBOM(control As IRibbonControl) '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 groupBegin, groupEnd As Integer 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 levels' column top cell", Type:=8) StartRow = StartCell.ROW LevelCol = StartCell.Column LastRow = ActiveSheet.UsedRange.End(xlDown).ROW 'empty rows above aren't included in UsedRange.rows.count => UsedRange.End '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 groupBegin = StartRow + 1 'For the first group For i = StartRow + 1 To LastRow CurrentLevel = Cells(i, LevelCol) If Cells(i, LevelCol).Value <> Cells(i - 1, LevelCol).Value Then groupEnd = i - 1 Rows(groupBegin & ":" & groupEnd).Select 'If is here to prevent grouping level that have only one row If Cells(groupBegin - 1, LevelCol).Value = Cells(groupBegin, LevelCol).Value Then Selection.Rows.Group groupBegin = i + 1 'adding one to keep the group's first row End If Next i 'For last group Rows(groupBegin & ":" & LastRow).Select Selection.Rows.Group ActiveSheet.Outline.ShowLevels RowLevels:=1 'Minimize all the groups ActiveSheet.Outline.SummaryRow = xlAbove 'Put "+" next to first line of each group instead of the bottom Application.ScreenUpdating = True 'Turns on screen updating when done.
End Sub
