自动分组Excel VBA

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

注意:加号显示组.

我有上面这样的表,我已经用子级索引了部分.我试图使用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将无法正确显示+-signs,我猜这是由于这些特定方案中缺少空间.如果遇到这种情况,您可以使用+-signs所在列的顶部的编号按钮来缩小和扩展不同的级别.这将扩展/收缩该特定子级别的所有组,但是,它不是最佳.但是它就是这样啊.

假设这样的设置(这是在分组之后 - 你可以在+这里看到缺少的符号,例如对于组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