макрос Excel для группировки не непрерывных данных

Question

Первое изображение - это мой набор данных Col A через col AX, часть макроса переводит уравнение в AY.

image 2 - мой желаемый идеальный результат

col A - это уровень отчета, col AY - урезанная версия A. col B - это элемент / do c строка, L для элемента, blank для do c. col c - счетчик предметов (увеличивается на 10 с каждым новым предметом, но сохраняется, если делать c), поднимается с последнего предмета на этом уровне. Все это полезно для конечной цели. Эта цель состоит в том, чтобы поместить нетронутый отчет в файл, кнопка запускает макрос, который группирует строки в соответствии с уровнем отчета и некоторым форматированием.

Этот отчет / пример имеет 4 слоя, я хотел бы код запустить снизу вверх и сгруппировать найденные уровни 4 (rows 34:37), затем продолжить сканирование вверх до строки 2. Снова перезапустите сканирование снизу для уровня 3 (rows 31:44, 15:16) , перезапустите и найдите 2, затем перезапустите и найдите 1. Уровни, которые выходят из отчета, могут достигать 25.

Вот мой код, и он не группируется должным образом, поэтому открыт для любых предложений.

    Sub FORMAT_SAP_ZPL_BOMEX_report_MK_01_01()
    '
    ' grouping_BOMEX_report Macro
    '
    ' ========== takes report from SAP tcode "ZPL_BOMEX" and
    ' ========== reorginazes the dataout put into something cleaner
    '

    'Application.ScreenUpdating = False

        With ActiveSheet.Outline
            .AutomaticStyles = False
            .SummaryRow = xlAbove
            .SummaryColumn = xlLeft
        End With

    ' \\\    get last row and column of data

    Dim lrow As String
    Dim nextblank As String

    ' \\\    last row
        lrow = Cells(Rows.Count, 1).End(xlUp).Row

        gmax = Application.WorksheetFunction.Max(Range("ay:ay"))

    For g = gmax To 0 Step -1

        For scanRow = lrow To 2 Step -1
        If Range("AY" & scanRow) = g Then
            Range("AZ" & scanRow) = 1
            End If
                Next scanRow


              EndRow = Cells(Cells.Rows.Count, "AZ").End(xlUp).Row
    jumpin1:
              StartRow = Range("AZ" & EndRow).End(xlUp).Row

                          Rows(StartRow & ":" & EndRow).Rows.Group
    '            Rows(StartRow & ":" & EndRow).Select
    '                Selection.Rows.Group


        nextblank = Range("AZ" & StartRow).End(xlUp).Row

           If nextblank > 2 Then
                EndRow = Range("AZ" & nextblank).Row
                    GoTo jumpin1

                Else
                    End If


        ActiveSheet.Columns(52).ClearContents


    Next g
end sub

Answer 1

Try,

Подгруппа должна быть сформирована заново в пределах области действия верхней группы,

Оказавшись в сгруппированном диапазоне, вы должны выполнить цикл и группирование. Поэтому вы можете создать группу с помощью рекурсивной функции.

Sub test()
    Dim dic As Object
    Dim vDB, vR()
    Dim rngDB As Range, rng As Range
    Dim i As Long, n As Long

    Set dic = CreateObject("Scripting.Dictionary")
    Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp))
    vDB = rngDB

    rngDB.ClearOutline

    For i = 1 To UBound(vDB, 1)
        If Not dic.exists(vDB(i, 1)) Then
            dic.Add vDB(i, 1), vDB(i, 1)
            n = n + 1
            ReDim Preserve vR(1 To n)
            vR(n) = vDB(i, 1)
        End If
    Next i

    rngGroup rngDB, vR

    rngDB.Rows.Group
End Sub
Sub rngGroup(rngDB As Range, v As Variant)
    Dim rng As Range, rngU As Range
    Dim n As Integer, k As Long, z As Long
    Dim rngF As Range, rngS As Range

    For z = 2 To UBound(v)
        For Each rng In rngDB

            If n <= UBound(v) Then
                s = v(z)
                If rng <> v(z - 1) And rng = s Then
                    If rngU Is Nothing Then
                        Set rngU = rng
                    Else
                        Set rngU = Union(rng, rngU)
                    End If
                End If
            End If
        Next rng
        If Not rngU Is Nothing Then
            k = rngU.Areas.Count

            For j = k To 2 Step -1
                    Set rngF = rngU.Areas(j)
                    Set rngS = rngU.Areas(j - 1)

                    rngGroup rngF, v

                    Set rng1 = rngF.Range("a" & rngF.Rows.Count).Offset(1, 0)
                    Set rng2 = rngS.Range("a1").Offset(-1, 0)
                    Range(rng1, rng2).Rows.Group
            Next
       End If
    Next z
End Sub

Изображение результата

Answer 2

мой готовый код, который работает. Я не знаю, есть ли способ сохранить несколько диапазонов одновременно, что избавило бы от необходимости хотя бы одного уровня l oop Я считаю

Sub FORMAT_SAP_ZPL_BOMEX_report_MK_01_02()
'
' grouping_BOMEX_report Macro
'
' ========== takes report from SAP tcode "ZPL_BOMEX" and
' ========== reorginazes the dataout put into something cleaner
'

Application.DisplayAlerts = False
Application.ScreenUpdating = False

    With ActiveSheet.Outline
        .AutomaticStyles = False
        .SummaryRow = xlAbove
        .SummaryColumn = xlLeft
    End With

' \\\    get last row and column of data

Dim lrow As String
Dim nextblank As String

' \\\    last row
    lrow = Cells(Rows.Count, 1).End(xlUp).Row

' \\\    drop group level trim into col AY
    Range("AY2:AY" & lrow).FormulaR1C1 = _
        "=VALUE(TRIM(RIGHT(SUBSTITUTE(RC[-50],""."",REPT("" "",LEN(RC[-50]))),LEN(RC[-50]))))"

' \\\    find max for grouping levels
        Range("AY1").FormulaR1C1 = "=MAX((R[1]C:R[99999]C))"
            gmax = Range("AY1").Value

' \\\    loop thru group levels (g), loop rows looking in col AY for any that match g
'           if they match g, mark col AZ with a 1, then group all rows with 1 in col AZ
'           then hide group, and look above for more rows matching g

For g = gmax To 1 Step -1

    For scanRow = lrow To 2 Step -1
        If Range("AY" & scanRow) = g Then
            Range("AZ" & scanRow) = 1
        End If
    Next scanRow

' \\\    define group range
          EndRow = Cells(Cells.Rows.Count, "AZ").End(xlUp).Row
jumpin1:
    If g = 1 Then
        StartRow = 3
            Else
        StartRow = Range("AZ" & EndRow).End(xlUp).Row
    End If
        Rows(StartRow & ":" & EndRow).Rows.Group
            Rows(StartRow & ":" & EndRow).Rows.EntireRow.Hidden = True

' \\\    check above for more rows in same group level
    nextblank = Range("AZ" & StartRow).End(xlUp).Row

       If nextblank > 2 Then
            EndRow = Range("AZ" & nextblank).Row
                GoTo jumpin1

            Else
                End If

' \\\    clear col AY for next level (g)
    ActiveSheet.Columns(52).ClearContents


Next g

' \\\    final top level grouping, catching any docs that are attached to top level mat #
    Rows("3:" & lrow).Rows.Group
        ActiveSheet.Outline.ShowLevels RowLevels:=3

' \\\    clear col AY and AZ
ActiveSheet.Columns(52).ClearContents
ActiveSheet.Columns(53).ClearContents

Range("e2").Select


' \\\    Format sheet

' \\\    fix ref des column issue

Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub