在Excel中使用vba设置外键约束

假设我有以下电子表格：

ABCDEFGHI ---------------------------------------------------------------------------- code dataElem age sex place type value denom denom_code ---------------------------------------------------------------------------- a1 population all all all num 10 1 1 a2 population all all rural num 6 1 1 a3 population all all urban num 4 1 1 a4 wealthy all all all % 40 10 a1 a5 wealthy all all all % 34 6 a2 a6 wealthy all all all % 50 4 a3 a7 Educated all all all % 70 10 a1 a8 Educated all all all % 50 6 a2 a9 Educated all all all % 100 4 a3 ... 

具有上面给出的值，以及列G中的列A和单元G2-G4（10,6和4）中的单元格A2-A4（即，a1，a2和a3）是主键的位置。 我想强制后续字段使用上面定义的主键作为外键。 这就是input的新logging必须针对列H（denom）和列I（denom_code）的外键单元进行检查。 为了进一步解释，每当我selectinput一个新的logging说第5行（a4，富裕，所有，所有，所有，％，40,10，a1），代码检查，以确保H5和I5对应A2 = A1和G2 = 10。 对于第6行（a5，富有，全部，全部，％，34,6，a2），H6和I6都对应于A3 = a2和G3 = 6。 我如何在Excel VBA中实现这一点 。

 Sub sbHighlightDuplicatesInColumn() Dim lastRow As Long Dim matchFoundIndex As Long Dim iCntr As Long lastRow = Sheets("Sheet1").Range("A1").SpecialCells(xlCellTypeLastCell).Row For iCntr = 1 To lastRow If Cells(iCntr, 1) <> "" Then matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range(Cells(1, 1), Cells(iCntr, 1)), 0) If iCntr <> matchFoundIndex Then Sheets("Sheet1").Cells(iCntr, 1).Interior.Color = vbYellow End If End If Next 'iterating over the 2 columns... numOfRows = ActiveWorkbook.Worksheets("Sheet1").Range("A2", Worksheets("Sheet1").Range("A2").End(xlDown)).Rows.Count freq = numOfRows / 12 Dim lastRowL As Long lastRowL = Sheets("Sheet1").Range("L1").SpecialCells(xlCellTypeLastCell).Row Dim LastRowM As Long LastRowM = Sheets("Sheet1").Range("M1").SpecialCells(xlCellTypeLastCell).Row Dim rg1 As Range, rg2 As Range Set rg1 = ActiveWorkbook.Worksheets("Sheet1").Range("A2:A4") Set rg2 = ActiveWorkbook.Worksheets("Sheet1").Range("G2:G4") ' Create dynamic array Dim tmpArray1 As Variant, tempArray2 As Variant Dim code As Variant, value As Variant 'Dump the range into a 2D array tmpArray1 = rg1.value tmpArray2 = rg2.value 'Resize the 1D array ReDim code(1 To UBound(tmpArray1, 1)) ReDim value(1 To UBound(tmpArray2, 1)) 'Convert 2D to 1D For i = 1 To UBound(code, 1) code(i) = tmpArray1(i, 1) value(i) = tmpArray2(i, 1) Next For cnt = 1 To freq 'iterate over col-L Dim u As Integer, v As Integer u = cnt * 3 + 2 v = u + 2 Dim iTrack As Integer iTrack = 1 'iterate over col-L For iCntr = u To v If Cells(iCntr, 8) <> "" Then matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 8), Range(Cells(1, 8), Cells(iCntr, 8)), 0) If code(iTrack) <> matchFoundIndex Then Sheets("Sheet1").Cells(iCntr, 8).Interior.Color = vbYellow Else Sheets("Sheet1").Cells(iCntr, 8).Interior.Color = vbGreen End If End If iTrack = iTrack + 1 Next iTrack = 1 'iterate over col-M For iCntr = u To v If Cells(iCntr, 9) <> "" Then matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 9), Range(Cells(1, 9), Cells(iCntr, 9)), 0) If value(iTrack) <> matchFoundIndex Then Sheets("Sheet1").Cells(iCntr, 9).Interior.Color = vbRed Else Sheets("Sheet1").Cells(iCntr, 9).Interior.Color = vbGreen End If End If iTrack = iTrack + 1 Next Next End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim curColor As Variant curColor = ActiveCell.Interior.Color If Application.CountIf(Range("A:A"), Target) > 1 Then MsgBox "Duplicate Data", vbCritical, "Remove Data" Target.value = "" 'ActiveCell.Offset(RowOffset:=-1).EntireRow.Interior.Color = curColor End If End Sub