自动填色提示（已解决）

jx928867128

感觉这个有点难实现.zip (18.71 KB, 下载次数: 3)

2024-3-12 16:43 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

运行后一片红色，感觉汇总表中的数据摸拟得不太合理。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.12
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("班级课时")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         c = .UsedRange.Columns.Count
   
8.         arr = .[a1].Resize(r, c)
   
9.     End With
   
10.     For i = 2 To UBound(arr)
    
11.         For j = 2 To UBound(arr, 2)
    
12.             S = arr(i, 1) & "|" & arr(1, j)
    
13.             d(S) = Val(arr(i, j))
    
14.         Next
    
15.     Next
    
16.     On Error Resume Next
    
17.     With Sheets("汇总")
    
18.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
19.         c = .UsedRange.Columns.Count
    
20.         arr = .[a1].Resize(r, c)
    
21.         .Cells.Interior.ColorIndex = 0
    
22.         For i = 5 To UBound(arr)
    
23.             For j = 2 To UBound(arr, 2)
    
24.                 If arr(i, j) <> Empty Then
    
25.                     b = Split(arr(i, j), Chr(10))
    
26.                     S = arr(i, 1) & "|" & b(0)
    
27.                     If d.Exists(S) Then
    
28.                         m = Val(Mid(b(1), 3))
    
29.                         If m = d(S) Then .Cells(i, j).Interior.ColorIndex = 0
    
30.                         If m > d(S) Then .Cells(i, j).Interior.ColorIndex = 3
    
31.                         If m < d(S) Then .Cells(i, j).Interior.ColorIndex = 10
    
32.                     End If
    
33.                 End If
    
34.             Next
    
35.         Next
    
36.     End With
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    
41. 
    

复制代码

jx928867128

ykcbf1100 发表于 2024-3-12 17:05
参与一下。。。

谢谢老师的多次帮忙，万分感谢，估计是我没表达清楚，我想实现的是不人工运行代码，就是我在汇总表中录入排课卡片（课程与老师）时，程序自动计算每个班级内（同一行中的数据）每个科目安排的节数，再自动填充颜色提示。

ykcbf1100

jx928867128 发表于 2024-3-12 18:24
谢谢老师的多次帮忙，万分感谢，估计是我没表达清楚，我想实现的是不人工运行代码，就是我在汇总表中录入 ...

你是想用工作表事件？

jx928867128

ykcbf1100 发表于 2024-3-12 18:39
你是想用工作表事件？

谢谢老师的再次回贴，是的,您当前写的程序我刚也测试了，345班各科目安排的课时数与班级课时数是相等的，但程序填了红色，正确的结果是无填充色。

ykcbf1100

好吧，改为工作表事件

ykcbf1100

代码如下：

1. Private Sub Worksheet_Change(ByVal T As Range)
   
2.     If T.Column < 2 Or T.Column >= 100 And T.Row < 5 Then Exit Sub
   
3.     Dim arr, d
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     With Sheets("班级课时")
   
7.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
8.         c = .UsedRange.Columns.Count
   
9.         arr = .[a1].Resize(r, c)
   
10.     End With
    
11.     For i = 2 To UBound(arr)
    
12.         For j = 2 To UBound(arr, 2)
    
13.             S = arr(i, 1) & "|" & arr(1, j)
    
14.             d(S) = Val(arr(i, j))
    
15.         Next
    
16.     Next
    
17.     On Error Resume Next
    
18.     With Sheets("汇总")
    
19.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
20.         c = .UsedRange.Columns.Count
    
21.         arr = .[a1].Resize(r, c)
    
22.         .Cells.Interior.ColorIndex = 0
    
23.         For i = 5 To UBound(arr)
    
24.             For j = 2 To UBound(arr, 2)
    
25.                 If arr(i, j) <> Empty Then
    
26.                     b = Split(arr(i, j), Chr(10))
    
27.                     S = arr(i, 1) & "|" & b(0)
    
28.                     If d.Exists(S) Then
    
29.                         m = Val(Mid(b(1), 3))
    
30.                         If m > d(S) Then .Cells(i, j).Interior.ColorIndex = 3
    
31.                         If m < d(S) Then .Cells(i, j).Interior.ColorIndex = 8
    
32.                     End If
    
33.                 End If
    
34.             Next
    
35.         Next
    
36.     End With
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    

复制代码

jx928867128

ykcbf1100 发表于 2024-3-12 18:48
好吧，改为工作表事件

再次谢谢您的帮忙，测试时发现345班的填充色不对啊

65861954

jx928867128 发表于 2024-3-12 19:02
再次谢谢您的帮忙，测试时发现345班的填充色不对啊

买个排课软件吧。没必要再这里死磕。节约的时间去干点其它事情，学点其它东西挺好的。