このソリューションのコードには 2 つの部分があり、それぞれが属する場所に正確に配置する必要があります。最初の部分はイベント プロシージャです。ユーザーがHandbookの Department または Course を変更すると、自動的に起動します。この変更イベントは、関連するワークシート以外のブックのどこにも表示されません。したがって、コードはそのタブのコード モジュールにある必要があります。これは、この目的のために Excel によって設定された既存のモジュールです。
コードの 2 番目の部分は、"Records.xlsm" として特定した外部ワークブックを扱います。したがって、私はそれを標準コード モジュールに含めることを好みます。それはあなたが自分でセットアップしたモジュールです。デフォルトの名前はModule1になりますが、私は (プログラミング初心者を除いて) わかりやすい名前を付けることをお勧めします。ワークブックのコピーでは、ADO_Conn含まれている ADODB 接続にちなんで名前を付けました。
ADODB 接続に加えて、この部分には、ニーズや好みに合わせて調整できるさまざまなパラメーターも含まれています。これらは、数値定数に名前を割り当てる効率的な方法を提供する列挙の形をとります。それらのいくつかはコードの両方の部分で使用されるため、ここに配置しました。彼らのポイントは、コード自体を掘り下げることなく、コードを別の方法で機能させることです。いわばノブをひねるだけです。
ここまでフォローしてくださった方は、ボタンや F5 を押して実行するためのコードがないことに気付いたかもしれません。ADODB 接続はイベント プロシージャによって呼び出され、ユーザーがワークシートに加えた変更によってイベント プロシージャがトリガーされます。機能はシンプルです。ユーザーが変更を加えると、マクロは Department と Course の組み合わせを探し、見つからない場合はセルにマークを付けます。そこでユーザがエントリを変更すると、プロセスが繰り返され、ハイライトが削除される場合があります。ただし、 Recordsの後続の変更によってトリガーされる変更はありません。このような変更は、レコードワークブックの変更イベントによって行われる必要があります。
より正確な自動化が必要なほど、セットアップが必要になります。以下のパート 2 を (必要に応じて) という標準コード モジュールにコピーすることから始めADO_Connます。スペースをアンダースコアに置き換えて、名前がスペースを回避していることに注意してください。この規則は、アクセスされるRecords内の 2 つの列の名前にも適用されます。名前を「Dept_ID」と「Course_ID」に変更しました。別の名前を使用したり、列を他の場所に移動したりできますが、これらの名前に空白を含めることはできません。また、それらが言及されているコード内の 1 つの場所でそれらのシーケンスを変更することもできません。コード内の名前がワークブック内の名前と異なる場合でも、ワークブックは機能しますが、コードは機能しません。これがパート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
学科・コース ID 番号は 2 組あります。ハンドブックシートで使用される列 と、プログラム自体が使用するそれぞれの ID。列を必要な場所に移動できます。一緒にいる必要はありませんが、Department 列は Course 列の左側にある必要があると思います。名前に割り当てられた番号を変更するだけで、プログラムはそれらを見つけます。Handbookシートの FirstDataRow を変更することもできます。ただし、Recordsシートでは 1 つのヘッダー行のみが許可されます - 固定されているため、調整できません。
これがコードの最初の部分です。入力内容を確認するハンドブックのワークシートのコード モジュールに貼り付けます。
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ワークシートの名前を保持します。スペースがあると問題が発生する可能性があると思います。したがって、1 つを避けたほうがよいでしょう。最後に、ここで関係しているRecordsSrcClmsの 2 つの列の列キャプションの名前を示します。それらを実際の状態に揃え、空白を入れないようにし、シーケンスを Enum と揃えます。ADO（ActiveX Data Object、ところで）では、レコードに複数のヘッダー行を含めることができないことに注意してくださいNctシート。ヘッダー行に潜在的な一致が含まれていない限り、この特定のアプリケーションでさらに多くのものがあったとしても、違いはありません。ただし、そのシートのセルを結合することは避けてください。
