Автоматическая группировка 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 group, однако у меня более 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.

Edit:

В соответствии с просьбой подгруппой. Это на самом деле заставило меня застрять немного - я закодировал себя в угол и только едва вышел самостоятельно!

Несколько замечаний:

Я испытал это в какой-то степени (с 4 подуровней и нескольких родителей), и это работает прекрасно. Я попытался написать код, чтобы вы могли иметь столько подуровней или столько же родителей, сколько захотите. Но он не был тщательно протестирован, поэтому я ничего не мог гарантировать.

Однако в некоторых сценариях Excel неправильно отображает + -signs, я предполагаю, что это связано с отсутствием места в этих конкретных сценариях. Если вы столкнулись с этим, вы можете заключить контракты и развернуть разные уровни с помощью пронумерованных кнопок в верхней части столбца, в которых находятся + -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