自動分組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