我知道條件格式，但它沒有給我我正在尋找的選項：即，可以根據另一個單元格的顏色來手動更改單元格填充顏色（在受影響的單元格中），然后，一個如果我什么都不做，標準填充顏色。我有一個單行的 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
此致！
uj5u.com熱心網友回復：
這樣的事情會更好嗎？它只會在您更改 range 中的值時觸發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 指示的奇數/偶數行等等......現在這看起來不像一個完整的答案。
uj5u.com熱心網友回復：
試試這個。我從 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
我的測驗范圍：
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/372344.html