通过colorIndex计算条件格式化单元格
我有一些人，他们的工作时间通过他们自己列上的单元格中的条件格式显示 - 例如B7：B36，C7：C36，D7：D36等。我尝试将条件格式化单元格计数到列E.单元格中的最终结果是#Value（Arvo），但是当您按F9时，则可以显示数字。
当我逐步运行代码时，我注意到在“Range（”B6“，ws.Cells.SpecialCells（xlCellTypeLastCell））之后.ClearFormats程序跳转到函数”函数CountRed（MyRange As Range“并保持不变在循环中一段时间。
这是因为在单元格E6中有一个函数“CountRed（B6）+ CountGreen（C6）+ CountBlue（D6）”吗？
此外，我希望E栏中的列号集中在中央。
退出时间为空时出错：
结果出现错误：
结果应如下所示：
也可以找到原始代码here - 感谢Floris！
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
If Not Intersect(target, Range("B4:Q4")) Is Nothing Then
'Sub makeTimeGraph()
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim Applicaton
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 0.000001 ' a very small number - to take care of rounding errors in lookup
Dim entryName
Dim Jim
Dim Mark
Dim Lisa
Dim nameCols As Range
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B4 in this case:
entryTimeRow = 4
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A6:
Set timeRange = Range("A6", [A6].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
Set nameCols = Range("B3:Q3") ' columns where the names are in the third row
' clear previous formatting
Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats
Application.ScreenUpdating = False
' loop over each of the columns:
For Each c In timeCols.Cells
Application.StatusBar = entryName
If IsEmpty(c) Then GoTo nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
entryName = c.Offset(-1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
'select format range
formatRange.Select
' select name for coloring
Select Case entryName
Case "Jim"
Call formatTheRange1(formatRange) ' Red Colorinex 3
Case "Mark"
Call formatTheRange2(formatRange) ' Green Colorindex 4
Case "Lisa"
Call formatTheRange3(formatRange) ' Blue Colorindex 5
End Select
nextColumn:
Next c
End If
Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Private Sub formatTheRange1(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color red coloroindex 3
With r.Interior
.Pattern = xlSolid
.ColorIndex = 3
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Private Sub formatTheRange2(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color Green Colorindex 4
With r.Interior
.Pattern = xlSolid
.ColorIndex = 4
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Private Sub formatTheRange3(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color Blue Colorindex 5
With r.Interior
.Pattern = xlSolid
.ColorIndex = 5
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Function CountRed(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 3 Then
i = i + 1
End If
Next cell
CountRed = i
End Function
Function CountGreen(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 4 Then
i = iCount + 1
End If
Next cell
CountGreen = i
End Function
Function CountBlue(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 5 Then
i = i + 1
End If
Next cell
CountBlue = i
End Function
3 个答案:
答案 0 :(得分：0)
通过在#VALUE!(ARVO)程序的末尾添加ws.Calculate，可以解决Private Sub worksheet_change(ByVal target As Range)错误。
那说，你想要的结果：
- 员工工作时间的图示
- 有多少人在不同的时间间隔内工作
可以使用列B中的条件格式来完成：E列中的D和COUNTIFS函数。
在B栏中设置条件格式：
- 从B6向下选择与A列中最后一次相邻的单元格
- 单击“条件格式”，然后单击“使用公式...”选项
- 在公式框中输入
=AND(A6>=B$4,$A6<B$5) - 单击格式..按钮，然后选择填充颜色
- 点击确定
- 单击“应用”或“确定”以查看结果或关闭对话
您可以将条件格式复制到C列和D列，然后根据需要编辑其填充颜色。
在单元格E6中的公式：
=COUNTIFS(A6,">="&B$4,A6,"<"&B$5)
+COUNTIFS(A6,">="&C$4,A6,"<"&C$5)
+COUNTIFS(A6,">="&D$4,A6,"<"&D$5)
从B6向下复制到E，最后一行复制到F6; J6等。
完全不使用VBA，您将提高工作表的性能。通常最好在可能的情况下使用Excel功能和内置函数，并保留VBA来执行重复性任务，并创建UDF来计算使用内置函数无法完成的事情。
答案 1 :(得分：0)
Hyvääpäivää！这又是我...很高兴看到你继续改进你的代码。我做了一些调整，以使其更好地工作。特别是：
- 修改了
Target的测试 - 因此当您更改开始时间和更改结束时间时，它都会更新。你只是在改变开始时间时做事。 - 只有一个格式化函数而不是3，带有第二个参数（颜色）。这使代码更加整洁。你甚至可以有一个键/值对的字典 - 但是这不适用于Mac，我正在写这个，所以我不会告诉你。
- 隐藏在彩色单元格内的是
1，与背景颜色相同（因此“不可见”） - 这是由格式化功能添加的 - 现在，您的“总和”列只能包含您向下复制列的
SUM(B6:D6)样式公式。这比检查左侧单元格中颜色的三个自定义函数要快得多......（从代码中删除了这些函数） - 必须清除整个列的值（而不仅仅是格式化）才能删除上一次运行中遗留的任何
1;这是在每列循环中完成的（而不是一次完成）以在“每日”列中保留SUM()公式。 - 代码没有选择任何东西 - 所以最后没有什么可以取消选择的;这意味着每次进行编辑时，选择都不会跳转到A1单元格。
- 删除了
Dim Jim等语句，因为您没有使用这些变量。
既然代码正在修改工作表（通过添加不可见的单元来更改单元格中的值），则存在事情真正减慢的风险（每次更改都会导致事件再次触发） - 所以我关闭了事件当您进入该功能时，请在离开时再次打开它（分别使用Application.EnableEvents = False或True）;为了安全起见，错误也被捕获（使用On Error GoTo whoops） - 这些错误会将代码直接发送到代码的“启用事件和退出函数”部分。
据推测，您已经发现此代码需要存在于工作表代码中（而不是常规模块）才能正确接收事件。
这是新代码：
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
On Error GoTo whoops
If Not Intersect(target, Range("B4:Q5")) Is Nothing Then
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim Applicaton
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 1e-06 ' a very small number - to take care of rounding errors in lookup
Dim entryName
Dim nameCols As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B4 in this case:
entryTimeRow = 4
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A6:
Set timeRange = Range("A6", [A6].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
Set nameCols = Range("B3:Q3") ' columns where the names are in the third row
' clear previous values and formatting
Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats
' loop over each of the columns:
For Each c In timeCols.Cells
'Application.StatusBar = entryName
If IsEmpty(c) Then GoTo nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
entryName = c.Offset(-1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
' get rid of any values currently in this row:
timeRange.Offset(0, c.Column - 1).Clear
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
' select name for coloring
Select Case entryName
Case "Jim"
Call formatTheRange(formatRange, 3) ' Red Colorindex 3
Case "Mark"
Call formatTheRange(formatRange, 4) ' Green Colorindex 4
Case "Lisa"
Call formatTheRange(formatRange, 5) ' Blue Colorindex 5
End Select
nextColumn:
Next c
End If
whoops:
If Err.Number > 0 Then
MsgBox "error: " & Err.Description
Err.Clear
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range, c)
Dim cc
' Apply color c
With r.Interior
.Pattern = xlSolid
.ColorIndex = c
End With
r.Font.ColorIndex = c
' put an invisible 1 in each cell:
For Each cc In r.Cells
cc.Value = 1
Next
End Sub
以下是事物的外观（只显示一组列 - 但这在多列版本中应该可以正常工作）：
答案 2 :(得分：0)
我不是写宏的粉丝，除非你用尽了Excel的功能。不要通过ColorIndex攻击问题，而是返回数据源。在E6上使用此公式
{=SUM(($B$4:$D$4<=A6)*($B$5:$D$5>A6))}
请记住使用Ctrl + Shift + Enter启用数组功能，而不仅仅是Enter。粘贴下来，它将执行您的目标行为。
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？