如何在 Excel VBA 中优化此代码？

Question

我知道条件格式，但它没有给我我正在寻找的选项：即，可以根据另一个单元格的颜色手动更改单元格填充颜色（在受影响的单元格中），以及如果我什么都不做，那就是标准的填充颜色。我有一个单行的 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

最好的问候！

Answer 1

试试这个。我从 ColA 获取每一行的默认颜色。

这一切都在工作表代码模块中：

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

我的测试范围：

Answer 2

这样的东西会更好吗？它只会在您更改 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 指示的奇数/偶数行等等......这看起来并不完整现在回答。