自动分组Excel VBA [英] Automatic Grouping Excel VBA

问题描述

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

This Question has been answered, however I need help with one point. I am using the code provided in the answer, however I can not get the subgrouping, for the entirety of the document. Is such thing possible?

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

注意：Plusses显示组。

NOTE: Plusses shows groups.

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

I have such table as above, where I have indexed the sections with sublevels. I am trying to group those section using excel group feature, however, I have over 3000 rows of data, so I am trying to automate the process. I have modified a Excel VBA macro I found here and got this code below.

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）并对它们进行分组。这不是通过代码实现的。另外，如果相邻的行是相同的索引，代码会跳过分组。

Basically what I am trying to do in the above code is to select the top index and run down the cells until that index is the same value again. Basically for the example chart, I would like to select rows(2:4) and group them. This is not achieved by the code. Also, code skips grouping if the adjacent rows are with the same index.

这是一个可行的方法，还是应该重新考虑我的循环呢？

Is this a viable method or should I re-think my loops and how?

推荐答案

你到达的代码对我来说似乎有点复杂。更改您的需求并尝试这样做：

The code you have arrived at seems a little convoluted to me. Change to your needs and try this:

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

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

Note that there is no error-handling here, the code is a little verbose for readability and bonus - no select.

编辑：

按要求，子分组。这实际上让我陷入困境 - 我将自己编码到一个角落，只是几乎没有自己出来！

As requested, the subgrouping. This actually had me stuck for a bit - I coded myself into a corner and only barely got out on my own!

几个注释：

我已经在一定程度上测试了（有4个子级和多个父母），它的工作很好。我试图编写代码，以便您可以拥有尽可能多的子级别或者尽可能多的父母。但是没有经过广泛的测试，所以我无法保证。

I have tested this to some extent (with 4 sublevels and multiple parents) and it works nicely. I tried to write the code so that you can have as many sublevels or as many parents as you want. But it has not been extensively tested, so I couldn't guarantee anything.

然而，对于某些情况，Excel将无法正确显示 + -signs，我猜这是因为在这些特定情况下缺乏空间。如果遇到这种情况，您可以使用 + -signs所在的列顶部的编号按钮来合并和扩展不同的级别。这将扩展/合并<然而，这个特定子级别的所有组都是最优的。但是这是它是什么。

However, for some scenarios, Excel won't properly display the +-signs, I am guessing that is due to lack of space in these particular scenarios. If you encounter this, you can contract and expand the different levels using the numbered buttons at the top of the column the +-signs are located in. This will expand/contract all groups of that particular sub-level, however, so it is not optimal. But it is what it is.

假设一个这样的设置（这是分组后 - 你可以看到缺少的 + -signs在这里，例如对于1.3和3.1组，但他们分组！）：

Assuming a setup like this (this is after the grouping - you can see the missing +-signs here, for example for group 1.3 and 3.1 -- but they are grouped!):

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

这篇关于自动分组Excel VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！