How can I optimize this code in Excel VBA?-CodePudding

I know about conditional formatting, but it doesn't give me the options I'm looking for: namely, the possibility to manually change the cell fill color (in affected cells) based on how a color another cell, and with that, a standard fill color if I don't do anything. I have this VBA code for a single row (see below) and it works, though I have a feeling it's complicated in itself. Now, I want the same thing for another 149 rows, but the code obviously gets to complex. How can I achieve this? Is it wrong to put this in a SelectionChange?

Code:

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

Best regards!

CodePudding user response：

Would something like this be better? It will only fire when you change a value in the range F7:PB7.
It won't fire if the cell value is updated through a formula (for that you'd want to look at the cell that you changed to make the formula update).

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

Edit: Updated the range so it looks at more than one row, but now thinking I should delete the answer due to the odd/even rows that @Cyril indicates, etc.... this isn't looking like a complete answer now.

CodePudding user response：

Try this out. I'm getting the default color for each row from ColA.

This is all in the worksheet code module:

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=" & 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

My test range: