自动分组Excel 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 

注：Plusses显示组。

我有这样的表，如上所述，我已经索引的章节与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将不会正确显示+-符号，我猜测这是由于这些特定场景中缺少空间。如果遇到这种情况，您可以使用标记所在的列的顶部的编号按钮收缩和展开不同级别。这将扩大/缩小全部该特定子级别的组，但是，如此它不是最佳的。但是它就是这样啊。

假设这样的设置（这是分组后 - 你可以在这里看到丢失的+ -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