此解决方案的代码有两部分，必须准确放置在它们所属的位置。第一部分是事件过程。当用户更改手册中的部门或课程时，它会自动触发。除了相关工作表之外，您的工作簿中的任何地方都不会注意到此更改事件。因此代码必须在该选项卡的代码模块中。这是一个现有的模块，由 Excel 为此目的而设置。
代码的第二部分处理我标识为“Records.xlsm”的外部工作簿。因此我更喜欢它在标准代码模块中。那是您自己设置的模块。默认名称为Module1，但我（在所有编程新手的支持下）建议提供一个描述性名称。在我的工作簿副本中，我将它命名ADO_Conn为它包含的 ADODB 连接。
除了 ADODB 连接外，这部分还包含各种参数，您可以根据自己的需要和喜好进行调整。它们采用枚举的形式，提供了一种将名称分配给数字常量的有效方法。我把它们放在这里是因为它们中的一些在代码的两个部分中都用到了。他们的目的是让您在不深入研究代码本身的情况下使代码以不同的方式工作。你只是旋转旋钮，就像它一样。
如果您到目前为止一直关注我，您可能已经注意到没有代码供您按下按钮或 F5 以使其运行。ADODB 连接由事件过程调用，事件过程由用户在工作表上所做的更改触发。功能很简单。当用户进行更改时，宏会查找部门和课程的组合，如果未找到则标记单元格。如果用户随后更改条目，则重复该过程并且可以移除突出显示。但是，记录中的后续更改不会触发任何更改。此类更改应由“记录”工作簿中的更改事件驱动。
您想要的自动化程度越高，设置就越精确。首先将下面的第 2 部分复制到一个名为ADO_Conn（如果您愿意）的标准代码模块。请注意，该名称通过用下划线代替空格来避免空格。此规则也适用于将要访问的Records中两列的名称。我将它们重命名为“Dept_ID”和“Course_ID”。您可以使用不同的名称，将列移动到其他位置，但您不能在这些名称中包含任何空格，也不应该在代码中提到它们的地方更改它们的顺序。如果代码中的名称与工作簿中的名称不同，则工作簿仍然可以工作，但代码不会。这是第 2 部分。
Option Explicit
Enum Nwt ' worksheet Target ("Handbook" = ThisWorkbook)
' 082
NwtFirstDataRow = 2 ' change to suit
NwtDept = 3 ' Columns: 3 = C
NwtCourse ' if no value is assigned, [preceding + 1]
End Enum
Enum Nct ' search criteria: TriggerRng()
' 082
NctDept = 1 ' do not change (!!)
NctCourse
End Enum
Function HasMatch(Crits As Variant, _
SrcFile As String, _
SrcTab As String, _
SrcClms As String) As Boolean
' 082
Dim ConSpec As String
Dim Conn As Object ' late-bound ADODB.Connection
Dim Rs As Object ' late-bound ADODB.Recordset
Dim Query As String ' SQL query
Dim Sp() As String ' array of Clms
On Error GoTo ErrExit
' Create the record set and ADODB connection
Set Rs = CreateObject("ADODB.Recordset")
Set Conn = CreateObject("ADODB.Connection")
With Conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & SrcFile & ";" & _
"Extended Properties=""Excel 12.0;" & _
"HDR=Yes;" & _
"IMEX=1"";"
.Open
End With
' create the SQL query string
Sp = Split("," & SrcClms, ",") ' first column index = 1
Query = "SELECT " & Sp(NctDept) & _
" FROM [" & SrcTab$ & "$]" & _
" WHERE " & Sp(NctDept) & " = " & Crits(1, NctDept) & _
" AND " & Sp(NctCourse) & " = " & Crits(1, NctCourse) & ";"
Rs.Open Query, Conn, 0, 1, 1 ' execute the query
' evaluate the retrieved recordset
HasMatch = Rs.EOF
ErrExit:
If Err Then
MsgBox "An error occurred during data retrieval:-" & vbCr & _
Err.Description, _
vbExclamation, "Error No. " & Err.Number
End If
Err.Clear
End Function
有 2 组部门/课程 ID 号。手册表中使用的列 以及程序本身使用的每个列的 ID。您可以将列移动到您想要的位置。他们不必在一起，但我认为 Department 列必须留在 Course 列的左侧。只需更改分配给名称的数字，程序就会找到它们。您还可以更改Handbook表的 FirstDataRow。但是记录表只允许一个标题行 - 固定，因此不可调整。
这是代码的第一部分。将其粘贴到您希望检查条目的手册中工作表的代码模块。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 082
' name the source workbook with its complete path (change to match your facts)
Const SrcPath As String = "D:\PVT Archive\Class 1\1-2020 (Jan 2022)\" ' end on \
Const SrcFile As String = "082 STO 200829 Records.xlsm"
Const SrcTab As String = "Records"
' match the column names in the workbook with the names used here.
' If they are changed assign names without spaces in them and
' maintain their logical sequence.
Const SrcClms As String = "Dept_ID,Course_ID"
Dim Matched As Boolean ' apply no highlight if True
Dim TriggerRng As Range ' the range that triggers action
Dim Crits As Variant ' search criteria
' don't react to changes in more than one cell
If Target.CountLarge > 1 Then Exit Sub
Set TriggerRng = Range(Cells(NwtFirstDataRow, NwtDept), _
Cells(Rows.Count, NwtDept).End(xlUp))
Set TriggerRng = Application.Union(TriggerRng, TriggerRng.Offset(0, NwtCourse - NwtDept))
If Not Intersect(Target, TriggerRng) Is Nothing Then
With Target
Set TriggerRng = Application.Union(Cells(.Row, NwtDept), _
Cells(.Row, NwtCourse))
Crits = TriggerRng.Value
If WorksheetFunction.CountA(TriggerRng) < 2 Then Exit Sub
End With
If Dir(SrcPath & SrcFile) = "" Then
' check if referenced workbook exists at the specified location
MsgBox "The workbook to be referenced" & vbCr & _
SrcFile & vbCr & "can't be found at" & vbCr & _
SrcPath & ".", _
vbInformation, "Data source not accessible"
Exit Sub
End If
With TriggerRng
If HasMatch(Crits, SrcPath & SrcFile, SrcTab, SrcClms) Then
.Interior.Color = vbYellow
Else
.Interior.Pattern = xlNone
End If
End With
End If
End Sub
您可以设置 4 个常量。这必须非常精确地完成。您可能还想查看消息的文本，如果您改进它们以更好地满足您的需要，我不介意。其余代码旨在保持不变。无论你想要什么修改都必须使用参数来完成，除非你发现功能上的缺陷，我希望你不会。
SrcPath保存工作簿Records的路径。它必须以反斜杠“”结尾。SrcFile保存该文件的名称。这个程序不介意它是打开还是关闭。SrcTab保存工作表的名称。我怀疑其中有一个空间可能会导致问题。所以，最好避免一个。最后，给出我们在此关注的RecordsSrcClms中两列的列标题名称。使它们与它们的真实情况保持一致，使它们没有空白，并使它们的序列与 Enum 保持一致。请注意 ADO（ActiveX 数据对象，顺便说一句）不允许您在记录中拥有超过 1 个标题行Nct床单。除非标题行包含潜在的匹配项，否则这并不是说如果有更多，它应该对这个特定的应用程序产生任何影响。但是，请避免在该工作表上的任何位置合并单元格。
