自动分组Excel VBA

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

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显示组。

我有这样的桌子，在那里我用索引索引了这些部分。 我正在尝试使用Excel组function对这些部分进行分组，但是，我有超过3000行的数据，所以我正在尝试自动化该过程。 我已经修改了我在这里find的Excel VBAmacros，并得到了下面的代码。

 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 

基本上我在上面的代码中要做的是select顶部索引，并沿着单元格运行，直到该索引再次是相同的值。 基本上对于示例图表，我想select行（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 

请注意，这里没有error handling，代码有点冗长的可读性和奖金 – 没有select 。

编辑：

按要求，分组。 这实际上让我陷入了一些困境 – 我把自己编入了一个angular落，只能勉强自己出来！

一些注意事项：

我已经在一定程度上testing了这个（有4个子代和多个父代），它的工作很好。 我试图编写代码，以便您可以拥有尽可能多的子级或多个父母。 但还没有经过广泛的testing，所以我不能保证任何东西。

但是，对于某些场景，Excel将不能正确显示+符号，我猜这是由于这些特定场景中缺less空间。 如果遇到这种情况，可以使用+标志所在列的顶部的数字button来缩小和扩大不同的级别。这将扩展/缩小特定子级别的所有组，但是，不是最佳的。 但是它就是这样啊。

假设这样的设置（这是在分组之后 – 你可以在这里看到缺失的+符号，例如组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