Пометьте одну и ту же строку в одном столбце одинаковым цветом

Question

Здесь у меня есть список строк в одном столбце таблицы Excel. Я хочу пометить ту же строку тем же цветом ячейки , что и на картинке (, если одна строка появляется только один раз, не нужно отмечать ее ).

Я старался изо всех сил со следующим кодом, чтобы получить результаты как:

    Sub color2()
        Dim y As Integer
        t = 1
        For y = 2 To 300
            If t = 1 Then
                If Range("R" & y) = Range("R" & y + 1) And IsEmpty(Range("R" & y)) = False Then
                    Rows(y).Interior.ColorIndex = 35
                    Rows(y + 1).Interior.ColorIndex = 35
                t = 2
                End If

            ElseIf t = 2 Then
                If Range("R" & y) = Range("R" & y + 1) And IsEmpty(Range("R" & y)) = False Then
                    Rows(y).Interior.ColorIndex = 36
                    Rows(y + 1).Interior.ColorIndex = 36
                    t = 1
                End If
            End If
        Next y
    End Sub

У него все еще проблемы с пометкой 3 непрерывной строки, как в строке 6 ~ 7. Пожалуйста, помогите мне. Спасибо огромное!

IMP
IMP
CL
CL
CD
CD
CD
VS_D
VS_D
VS_S
VS_S
VS_W
VS_DB
VS_DB
VS_SB
VS_SB

Answer 1

Попробуйте следующее:

Sub Test()

Dim lr As Long, x As Long, y As Long, z As Long
Dim arr As Variant, clr As Variant: clr = Array(35, 36)

With ThisWorkbook.Worksheets("Sheets1") 'Change according to your sheetname

    'Get last used Row and fill array
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A2:A" & lr).Value

    'Loop array and color
    For x = LBound(arr) To UBound(arr)
        y = WorksheetFunction.CountIf(.Range("A2:A" & lr), arr(x, 1))
        If y > 1 Then
            .Cells(x + 1, 1).Resize(y).Interior.ColorIndex = clr(z)
            Select Case z
                Case 0: z = 1
                Case 1: z = 0
            End Select
            x = x + y - 1
        End If
    Next x

End With

End Sub

Answer 2

Я добавил цветовую и строковую оценку перед каждым оператором if, и это работает идеально. Но, как более свежее с VBA, мне интересно, есть ли лучший способ решить эту проблему?

    Sub color2()
        Dim y As Integer
        colormark = 35
        For y = 2 To 300
            If colormark = 35 Then
                If Range("R" & y - 1).Interior.ColorIndex = 36 And Range("R" & y) = Range("R" & y - 1) Then
                    If Range("R" & y) = Range("R" & y + 1) And IsEmpty(Range("R" & y)) = False Then
                        Rows(y).Interior.ColorIndex = 36
                        Rows(y + 1).Interior.ColorIndex = 36
                        colormark = 35
                    End If

                ElseIf Range("R" & y) <> Range("R" & y - 1) Then
                    If Range("R" & y) = Range("R" & y + 1) And IsEmpty(Range("R" & y)) = False Then
                            Rows(y).Interior.ColorIndex = 35
                            Rows(y + 1).Interior.ColorIndex = 35
                            colormark = 36
                    End If
                End If

            ElseIf colormark = 36 Then
                If Range("R" & y - 1).Interior.ColorIndex = 35 And Range("R" & y) = Range("R" & y - 1) Then
                    If Range("R" & y) = Range("R" & y + 1) And IsEmpty(Range("R" & y)) = False Then
                            Rows(y).Interior.ColorIndex = 35
                            Rows(y + 1).Interior.ColorIndex = 35
                            colormark = 36
                    End If

                ElseIf Range("R" & y) <> Range("R" & y - 1) Then
                    If Range("R" & y) = Range("R" & y + 1) And IsEmpty(Range("R" & y)) = False Then
                            Rows(y).Interior.ColorIndex = 36
                            Rows(y + 1).Interior.ColorIndex = 36
                            colormark = 35
                    End If
                End If
            End If
        Next y
    End Sub