用于对非连续数据进行分组的 excel 宏

Question

第一张图片是我的数据集Col A 到col AX，部分宏将方程放入AY。

图 2 是我想要的完美结果

col A 是报告级别，col AY 是 A 的修剪版本。col B 是项目/文档行，L 是项目，blank 是文档。 col c 是项目计数器（每个新项目增加 10，但在 doc 中保持），从该级别的最后一个项目中拾取。这些对于最终目标是有用的。该目标是将未修改的报告放入文件中，一个按钮将运行宏，该宏根据报告级别和某些格式对行进行分组。

此报告/示例有 4 层，我希望代码从下到上运行并将找到的级别 4 分组 (rows 34:37)，然后继续向上扫描直到第 2 行。重新启动再次从底部扫描级别3's (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

试试，

子组必须在上组的范围内重新组成，

一旦进入分组范围，您必须循环和分组。因此，您可以使用递归函数创建组。

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

我完成的代码有效。我不知道是否有办法一次存储多个范围，我相信这将消除对至少一层循环的需要

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