Условное форматирование заливки фигуры на основе значения в Excel

Question

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

Answer 1

Shape Fill Changer

Лист1: Карта (Ливерпуль)

---

Формула Excel для ячейки E2 - это:

=D2-TODAY()+C2

Лист 2: Данные

---

Перед использованием этого кода внимательно изучите раздел константы изменить его в соответствии с вашими потребностями.Вставьте его в модуль и дополнительно добавьте соответствующий код ниже.

Имена фигур привязаны к идентификаторам кабелей и состоят из имени ядра формы "Cable" и идентификатора кабеля, например, если идентификатор кабеля равен 7, тогдаформа называется «Cable7».

Код написан так, что если вы меняете заголовок CABLE ID или DUE DAYS в листе данных, вы должны также изменить его в разделе констант.С другой стороны, вы можете вставить новые столбцы и перегруппировать столбцы, и код по-прежнему будет работать.

Option Explicit

Sub ShapeFillChanger()

  Const cStrCableId As String = "CABLE ID"    ' Cable ID Column Header
  Const cStrDaysData As String = "DUE DAYS"   ' Days Data Column Header
  Const cStrMap As String = "Sheet1"          ' Map Worksheet Name
  Const cStrData As String = "Sheet2"         ' Data Worksheet Name
  Const cStrShape As String = "Cable"         ' Shapes Core Name

  Dim objCableFirst As Range  ' Cable Number First Cell (incl. Header)
  Dim objCableLast As Range   ' Cable Number Last Cell
  Dim objDays As Range        ' Days Range
  Dim objCell As Range        ' Each Cell in Days Range

  Dim lngRGB As Long          ' RGB Color Value
  Dim intDays As Integer      ' Days Column Number

  ' Process worksheet containing data (Data Worksheet).
  With ThisWorkbook.Worksheets(cStrData)

    ' Find first cell containing cStrCableId.
    Set objCableFirst = .Cells _
        .Find(What:=cStrCableId, After:=.Cells(.Rows.Count, .Columns.Count), _
        LookIn:=xlFormulas, Lookat:=xlWhole, _
        SearchOrder:=xlByRows, SearchDirection:=xlNext)

    ' Find last cell containing data in column where cStrCableId was found.
    Set objCableLast = .Range(.Cells(1, objCableFirst.Column), _
        .Cells(.Rows.Count, objCableFirst.Column)) _
        .Find(What:="*", After:=.Cells(1, objCableFirst.Column), _
        LookIn:=xlFormulas, Lookat:=xlWhole, _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)

    ' Find first column containing cStrDaysData in row where cStrCabelId was
    ' found.
    intDays = .Range(.Cells(objCableFirst.Row, 1), _
        .Cells(objCableFirst.Row, .Columns.Count)) _
        .Find(What:=cStrDaysData, _
        After:=.Cells(objCableFirst.Row, .Columns.Count), _
        LookIn:=xlFormulas, Lookat:=xlWhole, _
        SearchOrder:=xlByRows, SearchDirection:=xlNext).Column

    ' Create reference to the range of Days Data (Days Range).
    Set objDays = .Range(.Cells(objCableFirst.Row + 1, intDays), _
        .Cells(objCableLast.Row, intDays)) ' " + 1" to exclude Header.

    ' Check each cell value in Days Range and apply changes to Map Worksheet.
    For Each objCell In objDays
      Select Case objCell.Value
        Case Is <= 0  ' Red:    SchemeColor = 2, RGB (255, 0, 0)
          lngRGB = RGB(255, 0, 0)
        Case Is <= 30 ' Yellow: SchemeColor = 5, RGB (255, 255, 0)
          lngRGB = RGB(255, 255, 0)
        Case Is > 30  ' Green:  SchemeColor = 3, RGB (0, 255, 0)
          lngRGB = RGB(0, 255, 0)
        Case Else
      End Select
      With ThisWorkbook.Worksheets(cStrMap).Shapes(cStrShape & _
          .Cells(objCell.Row, objCableFirst.Column))
        .Fill.ForeColor.RGB = lngRGB
      End With
    Next

  End With

End Sub

Для автоматического запуска приведенного выше кода каждый раз, когда в Таблице данных вносятся изменения в VBEдобавьте следующий код к листу ' Sheet2 ' code:

Private Sub Worksheet_Calculate()
  ShapeFillChanger
End Sub

Когда вычисляется таблица данных, цвета на листе карты будут обновляться.

Так как я решил, что карта является организатором шоу, я поместил ее в лист "Sheet1".

Answer 2

Вы не предоставили достаточно информации для точного решения, но, безусловно, это возможно. Я сделал следующее предположение в моем коде:

• Ваша карта марины находится на рабочем листе с именем "Карта" (вы можете изменить его, если он другой)
• Ваш отдельный лист с номерами кабелей находится на листе с именем «Данные» (вы можете изменить его, если он другой)
• У вас есть непрерывный диапазон, в котором перечислены все имена дисков с соответствующими датами обслуживания (вы также можете изменить диапазон)

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

    Dim shp As Shape
    Dim lng As Long
    Dim shtShapes As Worksheet, shtMaintenance As Worksheet
    Dim cll As Range, rngDates As Range, rngPoints As Range
    Dim str As String
    Dim i As Integer
    Dim dte As Date

    ' Sheet name for the marina map
    Set shtShapes = Sheets("Map")

    ' Sheet name for the maintemance data
    Set shtMaintenance = Sheets("Data")

    ' Range with maintenance data
    Set rngDates = shtMaintenance.Range("B2:B5")
    Set rngPoints = shtMaintenance.Range("A2:A5")
    dte = Now()

    With shtMaintenance
    ' Assign color based on the current date
        For Each cll In rngDates
            Select Case cll.Value - dte
                Case Is > 30: i = 3 'Green
                Case Is > 0: i = 5  'Yellow
                Case Is <= 0: i = 2 'Red
            End Select

    ' Get the corresponding shape name
            str = .Cells(cll.Row, cll.Column - 1).Value

    ' Set the new color
            With shtShapes
                Set shp = .Shapes(str)
                shp.Fill.ForeColor.SchemeColor = i
            End With
        Next
    End With