按公式值分组行

Question

与此问题非常相似-> Group rows by value

唯一的区别是我要分组的值是公式。参见下面的示例数据（似乎无法正确嵌入图像）

样本数据

所需的输出

下面的代码从上面链接的答案中进行了修改。

Sub demo()
    Dim r As Range
    Dim v As Variant
    Dim i As Long, j As Long

    With ActiveSheet
        On Error Resume Next
        ' expand all groups on sheet
        .Outline.ShowLevels RowLevels:=8
        ' remove any existing groups
        .Rows.Ungroup
        On Error GoTo 0
        Set r = .Range("D6", .Cells(.Rows.Count, 2).End(xlUp))
    End With

    With r
        'identify common groups in column D
        j = 1
        v = .Cells(j, 1).Formula
        For i = 2 To .Rows.Count
            If v <> .Cells(i, 1) Then
                ' Colum D changed, create group
                v = .Cells(i, 1)
                If i > j + 1 Then
                    .Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
                End If
                j = i
                v = .Cells(j, 1).Value
            End If
        Next
        ' create last group
        If i > j + 1 Then
            .Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
        End If
        ' collapse all groups
        .Parent.Outline.ShowLevels RowLevels:=1
    End With
End Sub