☰

Excel 宏根据单元格值对行进行分组

tag-icon • tag-icon microsoft-excel macros
Excel 宏根据单元格值对行进行分组

我在 Excel 工作表中有一个分层的项目列表，并且想要创建一个宏来根据提供缩进级别的单元格值对每行进行分组。数据如下所示：

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 3

宏运行后，2 级行将分组为一级（即相当于选择该行并按Alt+ Shift+ Right Arrow），3 级行将分组为两级。

答案1

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

答案2

我搜索了一个宏来根据这样的索引对行进行分组：

1
1
1
2
2
2
2
3
3
3

为此，我使用了您的宏并对其进行了一些更改：

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

相关内容