按列分组

Question

我需要帮助修改此VBA才能以与目前在行上工作方式完全相同的方式处理列。我现在在一张纸上使用它，它对我来说很完美，但我需要适应它。我最初在这里找到它，但我猜测如何修改它并没有成功。谢谢！

Sub TtlCoRecapGrouping()
Dim rng_cells As Range
    Dim rng_start As Range
    Dim rng_end As Range

    'set up some ranges, change rng_start to be appropriate
    Set rng_start = Range("A8")
    Set rng_end = rng_start.End(xlDown)
    Set rng_cells = Range(rng_start, rng_end)

    'clear previous outline
    Cells.ClearOutline

    'loop through level cells and group based on values below
    Dim cell As Range
    For Each cell In rng_cells

        'get value of cell and start checking below it
        Dim row_off As Integer
        row_off = 1

        'loop ensures level is greater below and cells are within range
        Do While cell.Offset(row_off) > cell And cell.Offset(row_off).Row <= rng_end.Row
            row_off = row_off + 1
        Loop

        'do the grouping if there are more than 1 cells below
        If row_off > 1 Then
            Range(cell.Offset(1), cell.Offset(row_off - 1)).EntireRow.Group
        End If
    Next cell
End Sub

Answer 1

Sub TtlCoRecapGrouping()

Dim rng_cells As Range
Dim rng_start As Range
Dim rng_end As Range
Dim i, j as integer

'set up some ranges, change rng_start to be appropriate
Set rng_start = Range("A8")
Set rng_end = rng_start.End(xlToRight)
Set rng_cells = Range(rng_start, rng_end)

'clear previous outline from columns
For i = 1 to Cells.Columns.Count
    If Columns(i).OutlineLevel > 1 Then
        For j = 2 to Columns(i).OutlineLevel
            Columns(i).Ungroup
        Next j
    End If
Next i

'loop through level cells and group based on values to the right
Dim cell As Range

For Each cell In rng_cells

    'get value of cell and start checking to the right of it
    Dim col_off As Integer
    col_off = 1

    'loop ensures level is greater to the right and cells are within range
    Do While cell.Offset(, col_off) > cell And cell.Offset(, col_off).Column <= rng_end.Column
        col_off = col_off + 1
    Loop

    'do the grouping if there are more than 1 cells to the right
    If col_off > 1 Then
        Range(cell.Offset(, 1), cell.Offset(, col_off - 1)).EntireColumn.Group
    End If
Next cell

End Sub