Блог

Я знаю об условном форматировании, но оно не дает мне вариантов, которые я ищу: а именно, возможность вручную изменять цвет заливки ячейки (в затронутых ячейках) на основе того, как цвет другой ячейки, и при этом стандартный цвет заливки, если я ничего не делаю. У меня есть этот код VBA для одной строки (см. Ниже), и он работает, хотя у меня такое чувство, что он сложен сам по себе. Теперь я хочу сделать то же самое еще для 149 строк, но код, очевидно, становится слишком сложным. Как я могу этого добиться? Неправильно ли помещать это в SelectionChange?

Код:

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Cell As Range
For Each Cell In Range("F7:PB7")
    If Cell.Value < Range("D8").Value Or Cell.Value > Range("E8").Value Then
        Cell.Offset(1, 0).Interior.ColorIndex = 0
    End If
    If Cell.Value >= Range("D8").Value And Cell.Value <= Range("E8").Value Then
        If Range("B8").Interior.ColorIndex < 0 Then
        Cell.Offset(1, 0).Interior.ColorIndex = 15
        Else
        If Range("B8").Interior.ColorIndex >= 0 Then
        Cell.Offset(1, 0).Interior.Color = Range("B8").Interior.Color
        End If
        End If
    End If

... et cetera next row ...

Next Cell
End Sub
 

С наилучшими пожеланиями!

Попробуйте это. Я получаю цвет по умолчанию для каждой строки из ColA.

Все это находится в модуле worksheet code:

 Option Explicit

Const RW_DATES As Long = 7          'row with headers and dates
Const COL_NAME As Long = 2          'column with person's name
Const COL_START_DATE As Long = 4    'column with start date
Const COL_DATE1 As Long = 6         '1st date on header row
Const NUM_ROWS As Long = 150        'how many rows?


Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim c As Range, rng As Range, rngDates As Range, i As Long
    Dim startDate, endDate, rw As Range, arrDates, rngRowDates As Range
    Dim CheckAll As Boolean, hiliteColor As Long, hiliteName As String
    Dim cName As Range, selName, selColor As Long
    
    
    CheckAll = Target Is Nothing 'called from selection_change?
    
    If Not CheckAll Then
        'Was a cell changed? see if any start/end date cells were changed
        Set rng = Application.Intersect(Target, _
                       Me.Cells(RW_DATES   1, COL_START_DATE).Resize(NUM_ROWS, 2))
        If rng Is Nothing Then Exit Sub   'nothing to do in this case
    Else
        'called from Selection_change: checking *all* rows
        Set rng = Me.Cells(RW_DATES   1, COL_START_DATE).Resize(NUM_ROWS)
    End If
    Debug.Print "ran", "checkall=" amp; CheckAll
    
    'header range with dates
    Set rngDates = Me.Range(Me.Cells(RW_DATES, COL_DATE1), _
                            Me.Cells(RW_DATES, Columns.Count).End(xlToLeft))
    arrDates = rngDates.Value 'read dates to array
    
    Set cName = NameHiliteCell() 'see if there's a hilited name
    If Not cName Is Nothing Then
        selName = cName.Value
        selColor = cName.Interior.Color
    End If
    
    'loop over each changed row
    For Each rw In rng.EntireRow.Rows
        
        Set rngRowDates = rw.Cells(COL_DATE1).Resize(1, rngDates.Columns.Count)
        rngRowDates.Interior.ColorIndex = xlNone 'clear by default
        
        startDate = rw.Cells(COL_START_DATE).Value   'read the dates for this row
        endDate = rw.Cells(COL_START_DATE   1).Value
        
        'determine what color the bar should be
        If Len(selName) > 0 And selName = rw.Cells(COL_NAME).Value Then
            hiliteColor = selColor
        Else
            hiliteColor = rw.Cells(1).Interior.Color
        End If
        
        If startDate > 0 And endDate > 0 Then
            i = 0
            For Each c In rngRowDates.Cells
                i = i   1
                If arrDates(1, i) >= startDate And arrDates(1, i) <= endDate Then
                    c.Interior.Color = hiliteColor
                End If
            Next c
        End If
    Next rw
End Sub

'just calls Worksheet_Change; add some delay to reduce frequency of firing
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Static lastrun As Date
    If lastrun = 0 Then lastrun = Now
    If Now - lastrun > (1 / 86400) Then
        lastrun = Now
        Worksheet_Change Nothing
    End If
End Sub

'find the first name cell which has any fill and return it
Function NameHiliteCell() As Range
    Dim c As Range
    For Each c In Me.Cells(RW_DATES   1, COL_NAME).Resize(NUM_ROWS)
        If Not c.Interior.ColorIndex = xlNone Then
            Set NameHiliteCell = c
            Exit Function
        End If
    Next c
End Function
 

Мой диапазон тестирования:

Будет ли что-то подобное лучше? Он будет срабатывать только при изменении значения в диапазоне F7:PB7 .
Он не будет срабатывать, если значение ячейки обновляется с помощью формулы (для этого вам нужно посмотреть на ячейку, которую вы изменили, чтобы обновить формулу).

 Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then 'Only fire if a single cell is changed.
        If Not Intersect(Target, Range("F7:PB154")) Is Nothing Then
            MsgBox Target.Address 'Test
            'Your code - looking at Target rather than each Cell in range.
        End If
    End If
End Sub
 

Редактировать: обновил диапазон, чтобы он просматривал более одной строки, но теперь думаю, что я должен удалить ответ из-за нечетных / четных строк, которые указывает @Cyril, и т.д….. сейчас это не похоже на полный ответ.