Выделите значения, где цвета совпадают в одной строке

Question

У меня есть лист Excel со значениями от B2: AF7, выделенными тремя разными цветами.Я использовал код VBA для значений выделения (код, не упомянутый в этом посте).

Мой вопрос:
Как можно выделить отдельным цветом, когда три цвета совпадают в одной строке.(см. рисунок: столбцы 11, 14, 15 и 4-й ряд были сопоставлены тремя разными цветами, я хотел бы выделить эти значения отдельным цветом)

Я написал следующий код, но он не работает.

Спасибо за ваше драгоценное время.

Dim r as range
Dim i as integer
set r = range("b2:af7")

For i = 2 To 31
    if r.Interior.ColorIndex = 3 and  r.Interior.ColorIndex = 4 and    r.Interior.ColorIndex = 6 then
        msgbox r.address
        r.Interior.ColorIndex = 37
    else
        msgbox "Row not found"
    end if
Next i

Answer 1

Подход с использованием регулярных выражений

Если вы преобразуете свои цветовые индексы диапазона данных…

… в последовательностьцветовых индексов, как показано ниже:

0000000003030600000000000000000
0006000000000000000000000000000
0400300000004000460000000000000
0000003000300460000046000000000
0000003330000000000000000000000

Вы можете использовать Регулярное выражение, чтобы найти цветовые узоры 346, 364, 436, 463, 634 и 643.

Я использовал следующий шаблон, чтобы игнорировать нули между ними:

3{1}0*4{1}0*6{1}|3{1}0*6{1}0*4{1}|4{1}0*3{1}0*6{1}|4{1}0*6{1}0*3{1}|6{1}0*3{1}0*4{1}|6{1}0*4{1}0*3{1}

В результате совпадения вы получите Match.FirstIndex, который представляет начальный столбец шаблона, и Match.Length, которыйпредставляет длину матча.

Итак, с помощью…

DataRange.Cells(iRow, Match.FirstIndex + 1).Resize(ColumnSize:=Match.Length)

… вы получаете диапазон текущей строки, которая соответствует шаблону.

Вот пример

Option Explicit

Public Sub FindColorPattern()
    Dim DataRange As Range 'define data range
    Set DataRange = ThisWorkbook.Worksheets("Sheet1").Range("B2:AF7")

    Dim iRow As Long
    For iRow = 1 To DataRange.Rows.Count 'loop row wise
        'read color indices into an array
        Dim PatternArray As Variant
        ReDim PatternArray(1 To DataRange.Columns.Count)
        Dim iCol As Long
        For iCol = 1 To DataRange.Columns.Count
            PatternArray(iCol) = DataRange(iRow, iCol).Interior.ColorIndex
            If PatternArray(iCol) <> 3 And PatternArray(iCol) <> 4 And PatternArray(iCol) <> 6 Then PatternArray(iCol) = 0
        Next iCol

        'find pattern
        Dim Matches As Object
        Set Matches = MatchPattern(Join(PatternArray, vbNullString))

        'mark found pattern in data range
        If Not Matches Is Nothing Then
            Dim Match As Object
            For Each Match In Matches
                With DataRange.Cells(iRow, Match.FirstIndex + 1).Resize(ColumnSize:=Match.Length)
                    'draw a border around the match
                    .Borders(xlEdgeBottom).LineStyle = xlSolid
                    .Borders(xlEdgeBottom).ColorIndex = 9
                    .Borders(xlEdgeTop).LineStyle = xlSolid
                    .Borders(xlEdgeTop).ColorIndex = 9
                    .Borders(xlEdgeLeft).LineStyle = xlSolid
                    .Borders(xlEdgeLeft).ColorIndex = 9
                    .Borders(xlEdgeRight).LineStyle = xlSolid
                    .Borders(xlEdgeRight).ColorIndex = 9
                End With
            Next Match
        End If
    Next iRow
End Sub


Function MatchPattern(TextToSearch As String) As Object
    Dim RegEx As Object, Matches As Object

    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
        .Pattern = "3{1}0*4{1}0*6{1}|3{1}0*6{1}0*4{1}|4{1}0*3{1}0*6{1}|4{1}0*6{1}0*3{1}|6{1}0*3{1}0*4{1}|6{1}0*4{1}0*3{1}"
    End With

    Set Matches = RegEx.Execute(TextToSearch)
    If Matches.Count > 0 Then
        Set MatchPattern = Matches
    Else
        Set MatchPattern = Nothing
    End If
End Function