Question

此问题已得到解答，但我需要一点帮助。我正在使用答案中提供的代码，但是对于整个文档，我无法获得子分组。这样的事情可能吗？

Section    Index
   1          1
+  1.1        2
++ 1.1.1      3
+++1.1.1.1    4
+++1.1.1.2    4
+++1.1.1.3    4
++ 1.1.2      3
++ 1.1.3      3
+  1.2        2
+  1.3        2
   2          1

注意：加号显示组。

我有上面的表，我用sublevels索引了部分。我试图使用excel组功能对这些部分进行分组，但是，我有超过3000行数据，所以我试图自动化该过程。我修改了一个我在这里找到的Excel VBA宏，并在下面得到了这段代码。

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 groupBegin, groupEnd As Integer
Dim i As Integer
Dim j As Integer
Dim n 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 To LastRow
    CurrentLevel = Cells(i, LevelCol)
    groupBegin = i + 1
    'Goes down until the entire subrange is selected according to the index
    For n = i + 1 To LastRow
        If Cells(i, LevelCol).Value = Cells(n, LevelCol).Value Then
            If n - i = 1 Then
            Exit For
            Else
                groupEnd = n - 1
                Rows(groupBegin & ":" & groupEnd).Select
            'If is here to prevent grouping level that have only one row
            End If
            Exit For
        Else
        End If
    Next n
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

基本上我在上面的代码中尝试做的是选择顶部索引并向下运行单元格，直到该索引再次为相同的值。基本上对于示例图表，我想选择行（2：4）并对它们进行分组。这不是由代码实现的。此外，如果相邻的行具有相同的索引，则代码会跳过分组。

这是一种可行的方法，还是我应该重新考虑我的循环以及如何？

Answer 1

你到达的代码对我来说似乎有点费解。改变你的需求并尝试这个：

Sub groupTest()
    Dim sRng As Range, eRng As Range ' Start range, end range
    Dim rng As Range
    Dim currRng As Range

    Set currRng = Range("B1")

    Do While currRng.Value <> ""
        Debug.Print currRng.Address
        If sRng Is Nothing Then
            ' If start-range is empty, set start-range to current range
            Set sRng = currRng
        Else
        ' Start-range not empty
            ' If current range and start range match, we've reached the same index & need to terminate
            If currRng.Value <> sRng.Value Then
                Set eRng = currRng
            End If

            If currRng.Value = sRng.Value Or currRng.Offset(1).Value = "" Then
                Set rng = Range(sRng.Offset(1), eRng)
                rng.EntireRow.Group
                Set sRng = currRng
                Set eRng = Nothing
            End If
        End If

        Set currRng = currRng.Offset(1)
    Loop
End Sub

请注意，这里没有错误处理，代码对于可读性和奖励有点冗长 - 没有select。

编辑：

根据要求，分组。这实际上让我陷入了一些困境 - 我把自己编成了一个角落，我自己几乎没有出来！

一些注意事项：

我已经在某种程度上对此进行了测试（有4个子级和多个父级）并且它运行良好。我试着编写代码，这样你就可以拥有尽可能多的子级或父母。但它还没有经过广泛的测试，所以我无法保证任何事情。

但是，对于某些情况，Excel无法正确显示+ - 符号，我猜这是由于这些特定情况下的空间不足。如果遇到这种情况，您可以使用+ - 列所在的列顶部的编号按钮来收缩和扩展不同级别。这将扩展/收缩所有组然而，这个特定的子级别，所以它不是最佳的。但事实就是如此。

假设这样的设置（这是在分组之后 - 你可以在这里看到缺少的+ - 符号，例如对于组1.3和3.1 - 但它们被分组！）：

Sub subGroupTest()
    Dim sRng As Range, eRng As Range
    Dim groupMap() As Variant
    Dim subGrp As Integer, i As Integer, j As Integer
    Dim startRow As Range, lastRow As Range
    Dim startGrp As Range, lastGrp As Range

    ReDim groupMap(1 To 2, 1 To 1)
    subGrp = 0
    i = 0
    Set startRow = Range("A1")

    ' Create a map of the groups with their cell addresses and an index of the lowest subgrouping
    Do While (startRow.Offset(i).Value <> "")
        groupMap(1, i + 1) = startRow.Offset(i).Address
        groupMap(2, i + 1) = UBound(Split(startRow.Offset(i).Value, "."))
        If subGrp < groupMap(2, i + 1) Then subGrp = groupMap(2, i + 1)
        ReDim Preserve groupMap(1 To 2, 1 To (i + 2))

        Set lastRow = Range(groupMap(1, i + 1))
        i = i + 1
    Loop

    ' Destroy already existing groups, otherwise we get errors
    On Error Resume Next
    For k = 1 To 10
        Rows(startRow.Row & ":" & lastRow.Row).EntireRow.Ungroup
    Next k
    On Error GoTo 0

    ' Create the groups
    ' We do them by levels in descending order, ie. all groups with an index of 3 are grouped individually before we move to index 2
    Do While (subGrp > 0)
        For j = LBound(groupMap, 2) To UBound(groupMap, 2)
            If groupMap(2, j) >= CStr(subGrp) Then
            ' If current value in the map matches the current group index

                ' Update group range references
                If startGrp Is Nothing Then
                    Set startGrp = Range(groupMap(1, j))
                End If
                Set lastGrp = Range(groupMap(1, j))
            Else
                ' If/when we reach this loop, it means we've reached the end of a subgroup

                ' Create the group we found in the previous loops
                If Not startGrp Is Nothing And Not lastGrp Is Nothing Then Range(startGrp, lastGrp).EntireRow.Group

                ' Then, reset the group ranges so they're ready for the next group we encounter
                If Not startGrp Is Nothing Then Set startGrp = Nothing
                If Not lastGrp Is Nothing Then Set lastGrp = Nothing
            End If
        Next j

        ' Decrement the index
        subGrp = subGrp - 1
    Loop
End Sub

Answer 2

上面的subGroupTest()函数可以替换为6行代码：

Sub subGroupTest()
    Dim cRng As range
    Set cRng = range("A1")
    Do While cRng.Value <> ""
        cRng.EntireRow.OutlineLevel = UBound(Split(cRng.Value, ".")) + 1
        Set cRng = cRng.Offset(1)
    Loop
End Sub

在同一OutlineLevel上的连续行会自动分组在一起，因此无需跳过所有箍圈即可手动解决深度问题。 OutlineLevel = 1表示该行也未分组。

作为奖励，不需要事先删除大纲级别。

自动分组Excel VBA

2 个答案: