VBA: цикл по объединенным ячейкам и применение форматирования для альтернативных строк

Question

Я использовал VBA для фильтрации значений из другого листа, и я думаю о том, как лучше отформатировать его для удобства чтения.Я объединил похожие значения и хотел бы выбрать соответствующие строки для каждой чередующейся объединенной ячейки и применить цветовую заливку.

Вот изображение для справки:

И этот код я использовал для получения текущего состояния.

Dim lRow As Long
lRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.DisplayAlerts = False
For i = lRow To 7 Step -1
    If Cells(i, 2) = Cells(i - 1, 2) Then
        Range(Cells(i, 2), Cells(i - 1, 2)).Merge
    End If
Next i
Application.DisplayAlerts = True

Есть ли способ вставить форматирование в цикл или иным образом?Я также открыт для других способов сделать таблицу более читабельной.

PS: Изображение, которое я прикрепил, просто для справки.Фактическая таблица, с которой я работаю, имеет тонны строк и столбцов, поэтому удобочитаемость важна.

Answer 1

За исключением объединения ячеек, код ниже делает то, что вы хотите.Вместо слияния код эффективно скрывает дубликаты заголовков элементов.

Option Explicit

Sub FormatData()
    ' 28 Feb 2019

    Const CaptionRow As Long = 1
    Const FirstDataRow As Long = 3              ' assuming row 2 to contain subtitles
    Const FirstDataClm As String = "B"          ' change as appropriate
    Const DescClm As String = "D"               ' change as appropriate

    Dim Desc As Variant, PrevDesc As Variant
    Dim Col() As Variant, ColIdx As Boolean
    Dim FontCol As Long
    Dim Rng As Range
    Dim Rl As Long, Cl As Long                  ' last Row / Column
    Dim R As Long

    Rl = Cells(Rows.Count, DescClm).End(xlUp).Row
    Cl = Cells(CaptionRow, Columns.Count).End(xlToLeft).Column
    Col = Array(15261367, 15986394)             ' sky, pale: change as required
    FontCol = Cells(FirstDataRow, FirstDataClm).Font.Color
    Application.ScreenUpdating = False

    For R = FirstDataRow To Rl
        Desc = Cells(R, DescClm).Value
        If Desc = PrevDesc Then
            Set Rng = Rng.Resize(Rng.Rows.Count + 1)
        Else
            If Not Rng Is Nothing Then
                SetColouring Rng, DescClm, Col(Abs(ColIdx)), FontCol
                ColIdx = Not ColIdx
            End If
            Set Rng = Range(Cells(R, FirstDataClm), Cells(R, Cl))
        End If
        PrevDesc = Desc
    Next R

    SetColouring Rng, DescClm, Col(Abs(ColIdx)), FontCol
    Application.ScreenUpdating = True
End Sub

Private Sub SetColouring(Rng As Range, _
                         ByVal C As String, _
                         ByVal Col As Long, _
                         ByVal Fcol As Long)
    ' 28 Feb 2019

    Dim R As Long

    With Rng
        .Interior.Color = Col
        .Font.Color = Fcol
        For R = 2 To .Rows.Count
            .Cells(R, Columns(C).Column - .Column + 1).Font.Color = Col
        Next R
    End With
End Sub

В верхней части кода есть некоторые константы, которые вы можете изменить.Также обратите внимание, что цвет шрифта, который вы используете в листе, предполагается найти в первой используемой ячейке листа, как указано константами.

Обратите внимание, что весь код выполняется на ActiveSheet.Я настоятельно призываю вас изменить этот бит и указать лист, предпочтительно как по его названию, так и по рабочей книге, в которой он находится. Если вы регулярно используете код, опубликованный выше, это всего лишь вопрос времени, прежде чем применить его к рабочему листу, который поврежден.в результате.