Question

我在excel中有一张表，我想在VBA中创建一个宏，以在F列中将具有相同值的行分组，并以粗体突出显示标题组。

换句话说，F列中所有具有相同值的行必须分组为一行，且标题为粗体。有可能吗？

这就是我所拥有的：
Actual Data

    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("F1", .Cells(.Rows.Count, 6).End(xlUp))
        r.Select
    End With

    With r
        j = 1
        v = .Cells(j, 1).Value
        For i = 2 To .Rows.Count
            If v <> .Cells(i, 1) Then
                ' Colum B 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

这就是我想要的：

Expected Data

非常感谢，我会很感激

Answer 1

我发现仅突出显示最上面的行更具视觉吸引力，但是您请求了所有行，因此这将解释如何双向进行。我100％肯定这是非常低效的，但是它对您现有的代码所做的更改最小，并可以提供所需的结果。

对于这两个版本，您都需要一个范围变量。从技术上讲这不是必需的，但我不想与i和j一起进行精神体操

Dim rng As Range

几乎在最底部，插入条件测试和格式化。

' create last group
If i > j + 1 Then
    .Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
    If Not rng Is Nothing Then
        rng.Interior.Pattern = xlSolid
        rng.Interior.Color = 65535
        rng.Font.Bold = True
        Set rng = Nothing
    End If
End If

要仅格式化组中最上面的行，请添加else并进行格式化-如果要突出显示所有行，请不要使用此部分

If v <> .Cells(i, 1) Then
    ' Colum B 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
Else
    Set rng = .Cells(j, 1)
    rng.EntireRow.Interior.Pattern = xlSolid
    rng.EntireRow.Interior.Color = 65535
    rng.EntireRow.Font.Bold = True
End If

要格式化组中的每一行，请声明另一个迭代变量，并改用该段

Dim k as long
If v <> .Cells(i, 1) Then
    ' Colum B changed, create group
    v = .Cells(i, 1)
    If i > j + 1 Then
        .Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
        If Not rng Is Nothing Then
            For k = 0 To 1
                rng.Resize(rng.Rows.Count + k, 1).EntireRow.Interior.Pattern = xlSolid
                rng.Resize(rng.Rows.Count + k, 1).EntireRow.Interior.Color = 65535
                rng.Resize(rng.Rows.Count + k, 1).EntireRow.Font.Bold = True
            Next
            Set rng = Nothing
        End If
    End If
    j = i
    v = .Cells(j, 1).Value
Else
    If Not rng Is Nothing Then
        Set rng = rng.Resize(rng.Rows.Count + 1, 1)
    Else
        Set rng = .Cells(j, 1)
    End If
End If

这两种变体之一应该可以带您去您想去的地方。

在VBA中将具有相同值的行分组

1 个答案: