禁排提示

jx928867128 · 发表于 2024-3-11 17:57

禁排提示.zip (23.3 KB, 下载次数: 6)

ykcbf1100 · 发表于 2024-3-11 19:07

标色提示。。。

ykcbf1100 · 发表于 2024-3-11 19:07

参与一下。。。

Sub ykcbf() '//2024.3.11
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
With Sheets("课程或教师禁排节次")
arr = .[a1:cu25]
For j = 2 To UBound(arr, 2)
If arr(3, j) = Empty Then arr(3, j) = arr(3, j - 1)
For i = 5 To UBound(arr)
If arr(i, j) <> Empty Then
s = arr(3, j) & "|" & arr(4, j) & "|" & arr(i, j)
d(s) = ""
End If
Next
Next
End With
With Sheets("汇总")
arr = .[a1:cu25]
.Cells.Interior.ColorIndex = 0
For j = 2 To UBound(arr, 2)
If arr(3, j) = Empty Then arr(3, j) = arr(3, j - 1)
For i = 5 To UBound(arr)
If arr(i, j) <> Empty Then
b = Split(arr(i, j), Chr(10))
For x = 0 To UBound(b)
s = arr(3, j) & "|" & arr(4, j) & "|" & b(x)
If d.exists(s) Then
.Cells(i, j).Interior.ColorIndex = 5 + Int(i / 5)
End If
Next
End If
Next
Next
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

gwjkkkkk · 发表于 2024-3-11 20:25

Option Explicit
Sub TEST6()
Dim ar, i&, j&, strKey$, strJoin$, dic As Object, regEx As Object

Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")

ar = Sheets(3).[B3].CurrentRegion.Value
For j = 1 To UBound(ar, 2)
      If ar(1, j) = Empty Then ar(1, j) = ar(1, j - 1)
      strKey = ar(1, j) & ar(2, j)
      strJoin = ""
      For i = 3 To UBound(ar)
         If Len(ar(i, j)) Then strJoin = strJoin & "|" & ar(i, j)
      Next i
      dic(strKey) = Mid(strJoin, 2)
Next j

Set regEx = CreateObject("VBScript.RegExp")
With [A4].CurrentRegion
      .Interior.Color = xlNone
      ar = .Value
      For j = 2 To UBound(ar, 2)
         If ar(1, j) = Empty Then ar(1, j) = ar(1, j - 1)
         strKey = ar(1, j) & ar(2, j)
         If dic.exists(strKey) Then
            If dic(strKey) <> "" Then
                  regEx.Pattern = dic(strKey)
                  For i = 3 To UBound(ar)
                     If regEx.test(ar(i, j)) Then .Cells(i, j).Interior.Color = vbYellow
                  Next i
            End If
         End If
      Next j
End With

Set dic = Nothing
Application.ScreenUpdating = True
Beep
End Sub

gwjkkkkk · 发表于 2024-3-11 20:27

参与一下。。。

yynrzwh · 发表于 2024-3-11 21:47

禁排提示.zip (40.31 KB, 下载次数: 11)

jx928867128 · 发表于 2024-3-15 07:14

ykcbf1100 发表于 2024-3-11 19:07
参与一下。。。

老师早上好，这个禁排提示代码可以帮忙写成工作表事件吗，再和那个自动填色的工作表事件代码合并，用起来就更方便。

jx928867128 · 发表于 2024-3-15 08:29

yynrzwh 发表于 2024-3-11 21:47

谢谢老师的帮忙，您这个代码方便帮忙写成工作表事件吗

		自动登录	找回密码
密码			免费注册

[求助] 禁排提示

评分

评分

评分

评分