условного форматирование петельчатого диапазона ячеек на основе значения в другой ячейке в VBA

Question

Я пытаюсь условно форматировать диапазон ячеек на основе числа в столбце слева каждую ячейку группировок. В принципе, если в строке 13 серый столбец слева от каждой группировки ячеек = 0, то я хочу, чтобы вся группировка клеток имела право на зеленый, если = 15, пожелтеть, если = 25 красным. Строка 12 - это то, что происходит с моим кодом прямо сейчас, а строка 13 - это то, что я хочу, чтобы она выглядела. Кажется, я не могу получить правильный цикл.

Sub Highlight3() 

    For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row 

    If Cells(i, 4) = "Highlight" Then 
     For j = 1 To 15 

    Range(Cells(i, j * 4 + 2), Cells(i + 1, j * 4 + 4)).Select 

     Selection.FormatConditions.Delete 
     Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23 = 0" 
     Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority 
      With Selection.FormatConditions(1).Interior 
      .Color = rgbRed 
     End With 

     Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23= 15" 
     Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority 
      With Selection.FormatConditions(1).Interior 
      .Color = rgbGold 
      End With 

     Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23 = 25" 
     Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority 
      With Selection.FormatConditions(1).Interior 
      .Color = rgbGreen 
      End With 


     Next j 
     End If 
    Next i 
End Sub 

Answer 1

Избегайте Select, потому что это медленно и unyieldy. Просто назначьте свои диапазоны переменным и работайте с ними.

Sub Highlight3() 

    For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row Step 2 

     If Cells(i, 4) = "Highlight" Then 
      For j = 1 To 15 

      Dim r As Range 
      Set r = Range(Cells(i, j * 4 + 2), Cells(i + 1, j * 4 + 4)) 

      Dim checkAddress As String 
      checkAddress = Cells(i, j * 4 + 1).Address 

      With r.FormatConditions 
       .Delete 

       .Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 0" 
       .Item(.Count).Interior.Color = rgbRed 

       .Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 15" 
       .Item(.Count).Interior.Color = rgbGold 

       .Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 25" 
       .Item(.Count).Interior.Color = rgbGreen 
      End With 

      Next j 
     End If 
    Next i 
End Sub 

вещи заметить:

• Нет более уродливого использование выбора - получить диапазон г один раз и делать все задачи с помощью условного форматирования в одном чистом блоке.

• Больше не устанавливает новые условные форматы в первую очередь. Отредактируйте это, если необходимо, но я предполагал, что это было то, что сделал Macro Recorder.

• Создает формулу форматирования для проверки по адресу, прямо слева от первой ячейки. Убедитесь, что выражение для checkAddress - это то, что вы ожидаете, потому что я должен был вывести его из вашей картинки и кода. Если эта область со значением 0/15/25 фактически представляет собой две объединенные ячейки (вроде бы выглядит так, как есть), то убедитесь, что эта формула предназначена для верхней ячейки, потому что эта ячейка будет той, которая фактически сохраняет значение.

• Опять же, трудно сказать только из картинки, но похоже, что каждая из ваших «строк» ​​на самом деле является двумя ячейками высокой (на основе вашего кода тоже). Таким образом, вы на самом деле хотите перейти через значения i по 2 за раз, а не по одному за раз.

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

Answer 2

Это должно делать то, что вы хотите, и быть немного быстрее:

Sub Highlight3() 

    Dim i As Long, j As Byte, myCols As Range, myRng As Range 

    Set myCols = Range("$B:$D") 

    For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row 
    If Cells(i, 4) = "Highlight" Then 

     If myRng Is Nothing Then 
     Set myRng = Intersect(Rows(i), myCols) 
     Else 
     Set myRng = Union(myRng, Intersect(Rows(i), myCols)) 
     End If 

     i = i + 1 'skip the line after, because it will never have a value/merged cell 

    End If 
    Next 

    If myRng Is Nothing Then Exit Sub 

    For i = 4 To 60 Step 4 
    For j = 0 To 1 
     With myRng.Offset(j, i) 

     .Cells(1).Offset(-j).Activate 
     .FormatConditions.Delete 'if that does not interfer with other stuff, better use the next line 
     'If j = 0 Then myCols.Offset(, i).FormatConditions.Delete 

     .FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=0" 
     .FormatConditions(.FormatConditions.Count).SetFirstPriority 
     .FormatConditions(1).Interior.Color = rgbRed 

     .FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=15" 
     .FormatConditions(.FormatConditions.Count).SetFirstPriority 
     .FormatConditions(1).Interior.Color = rgbGold 

     .FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=25" 
     .FormatConditions(.FormatConditions.Count).SetFirstPriority 
     .FormatConditions(1).Interior.Color = rgbGreen 

     End With 
    Next 
    Next 

End Sub 

протестировали его на месте, и она работала ... там могут быть проблемы, которые я не могу знать (лучше проверить его с копией ваша книга).

Первая часть подталкивает все линии в диапазоне, который используется во второй части. Таким образом, для каждой группы столбцов требуется всего 2 шага (нет необходимости запускать КАЖДУЮ строку).

Если у вас есть какие-либо вопросы или проблемы с этим кодом, просто спросите;)