Как закрасить ячейку в пределах диапазона, если соответствующая ячейка в пределах идентичного диапазона на другом листе уже окрашена?

Question

В VBA я отмечаю результаты в пределах диапазона и окрашиваю их в зеленый цвет на основе значения ячейки (например, значение <"28"). </p>

Каждый лист (всего четыре) соответствует отдельному маркеру ипомечен зеленым цветом в зависимости от значения.Все листы имеют одинаковую ось X и Y с диапазоном интереса (B2: BJ26).

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

Я мог бы сделать эту ячейку за ячейкой.

Упрощенный пример

If Sheets(A) "B2" value < 30 AND Sheets(B) "B2" Value > 1.1 AND
  Sheets(C) "B2" Value < 1500 AND Sheets(D) "B2" Value > 0.30 THEN
    Sheets(E) "B2" interior.color = RGB(0,255,0) 

Должен быть более эффективный способ для всех ячеек в B2: Диапазон BJ26.

Пример рабочего кода для задания значений цвета / флага на первых четырех листах.

Worksheets("1").Activate

Dim XXXXXXX As Range, cell As Range
Set XXXXXXX = Range("B2:BJ26")

For Each cell In XXXXXXX

    If cell.Value < "28" And cell.Value > "1" Then
        cell.Interior.Color = RGB(0, 255, 0)
    End If

Next

Предлагаемый следующий код не окрашивает ничего на листе 5

Sub ColorSheetFive()
    Dim i As Integer
    Dim m As Integer
    Dim n As Integer
    Dim allGreen As Boolean

    For m = 2 To 26
        For n = 2 To 62
            allGreen = True
            For i = 1 To 4
                If Sheets(i).Cells(m, n).Interior.Color <> RGB(0, 255, 0) Then
                    allGreen = False
                End If
            Next i
            If allGreen Then
                Sheets(5).Cells(m, n).Interior.Color = RGB(0, 255, 0)
            End If
        Next n
    Next m

    MsgBox "Color checking complete!"

End Sub

Answer 1

Форматирование одинаковых ячеек

• Загрузка рабочей книги (Dropbox)
• Примерное (неточное) описание: этот код не проверяет первые рабочие листы для Interior цветов, он скорее проверяет Min и Max Criteria для каждой ячейки и применяет форматирование, в то время как он подсчитывает количество вхождений критериев, встреченных в списке, который затем проверяется по количеству первых рабочих листов, иесли найдены, соответствующие ячейки на последнем листе форматируются.
• Вы можете добавить больше листов в список имен листов (cSheets), но ячейки в диапазоне всех, кроме последнего листа, будутотформатировать, если критерии выполнены, тогда как ячейки в диапазоне последней рабочей таблицы будут отформатированы, только если все ячейки в диапазонах всех предыдущих листов соответствуют критериям.
• Настройте другие значения в разделе констант какВы считаете нужным.

Код

Sub FormatSameCells()

    ' Worksheet Name List
    Const cSheets As String = "Sheet1,Sheet2,Sheet3,Sheet4,Sheet5"
    Const cRange As String = "B2:BJ26"  ' Source Range Address
    Const cMax As Long = 28             ' Max Criteria
    Const cMin As Long = 1              ' Min Criteria
    Const cColor As Long = 65280        ' Cell Color (Green)

    Dim rng As Range      ' Source Range, Target Range
    Dim vntS As Variant   ' Sheet Array
    Dim vntR As Variant   ' Range Array
    Dim vntT As Variant   ' Target Array
    Dim NoS As Long       ' Number of Sheets
    Dim NoR As Long       ' Number of Rows in Source Range
    Dim NoC As Long       ' Number of Columns in Source Range
    Dim i As Long         ' Range/Target Array Row Counter
    Dim j As Long         ' Sheet Array Element Counter,
                          ' Range/Target Array Column Counter
    Dim m As Long         ' Sheet Array Element Counter
    Dim str1 As String    ' Debug String

    ' Copy Worksheet Name List to 1D 0-based Sheet Array.
    vntS = Split(cSheets, ",")
    ' Calculate Number of Worksheets).
    NoS = UBound(vntS)

    With ThisWorkbook.Worksheets(Trim(vntS(UBound(vntS)))).Range(cRange)
        ' Calculate Number of Rows in Source Range/Range Array/Target Array.
        NoR = .Rows.Count
        ' Calculate Number of Columns in Source Range/Range Array/Target Array.
        NoC = .Columns.Count
    End With

    ' Adjust Target Array to size of Source Range/Range Array.
    ReDim vntT(1 To NoR, 1 To NoC) As Long

    ' Loop through all elements of Sheet Array, except the last one.
    For m = 0 To NoS - 1
        ' Create a reference to current Source Range.
        Set rng = ThisWorkbook.Worksheets(Trim(vntS(m))).Range(cRange)
        ' Clear Interior formatting in current Source Range.
        rng.Cells.Interior.ColorIndex = xlNone
        ' Copy Source Range in current worksheet (m) to 2D 1-based 1-column
        ' array in Array Array.
        vntR = rng
        ' Loop through rows of current array of Array Array.
        For i = 1 To NoR
            ' Loop through columns of current array of Array Array.
            For j = 1 To NoC
                ' Check value of current element of current array of
                ' Array Array for matching criteria.
                If vntR(i, j) > cMin And vntR(i, j) < cMax Then
                    ' Apply formatting to current cell in current Source Range.
                    rng.Cells(i, j).Interior.Color = cColor
                    ' Increase the number in current cell of Target Array.
                    vntT(i, j) = vntT(i, j) + 1
                End If
            Next
        Next
    Next

    ' Display contents of Target Array.
    str1 = String(40, "*") & vbCr & "Target Array [" & NoR & "," & NoC & "]" _
            & vbCr & String(40, "*")
    For i = 1 To NoR
        str1 = str1 & vbCr
        For j = 1 To NoC
            str1 = str1 & vntT(i, j)
        Next
    Next
    Debug.Print str1

    ' Create a reference to last (NoS) worksheet.
    Set rng = ThisWorkbook.Worksheets(Trim(vntS(NoS))).Range(cRange)
    ' Clear formatting in Target Range.
    With rng.Cells
        .Interior.ColorIndex = xlNone
        '.Font.Bold = False
    End With
    ' Loop through rows of Target Array.
    For i = 1 To NoR
        ' Loop through columns of Target Array
        For j = 1 To NoC
            ' Check if value of current element is equal to NoS.
            If vntT(i, j) = NoS Then
                ' Apply formatting to current cell in Target Range.
                With rng.Cells(i, j)
                    .Interior.Color = cColor
                    '.Font.Bold = True
                End With
            End If
        Next
    Next

End Sub

Очистить интерьер во всех листах

Sub ClearInterior()

    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets
        ws.Cells.Interior.ColorIndex = xlNone
    Next

End Sub

Answer 2

Ваш код ColorSheetFive работает без проблем?!

Option Explicit

Sub ColorSheet5()
    Dim RelevantRange As Range
    Dim RangeStr As String

    'vbGreen = 65280
    'rgb(0,255,0) = 65280

    Set RelevantRange = Range("B2:BJ26")
    For Each actCell In RelevantRange
        RangeStr = actCell.Address
        'Debug.Print Sheets("Sheet" & iCt).Range(RangeStr).Address
        If Check4Sheets(RangeStr, vbGreen) Then
            actCell.Interior.Color = vbGreen
        End If
    Next actCell
End Sub

Function Check4Sheets(CheckRange As String, RGB_Color As Long) As Boolean

    Check4Sheets = True
    If Check_Intertior_Color(1, CheckRange, RGB_Color) = False Then _
        Check4Sheets = False
    If Check_Intertior_Color(2, CheckRange, RGB_Color) = False Then _
        Check4Sheets = False
    If Check_Intertior_Color(3, CheckRange, RGB_Color) = False Then _
        Check4Sheets = False
    If Check_Intertior_Color(4, CheckRange, RGB_Color) = False Then _
        Check4Sheets = False

End Function

Function Check_Intertior_Color(SheetNr As Integer, CheckRange As String, RGB_Color As Long) As Boolean
    Check_Intertior_Color = False
    With Worksheets(SheetNr).Range(CheckRange)
        If .Interior.Color = RGB_Color Then
            Check_Intertior_Color = True
        End If
    End With
End Function