将两个数组与唯一值VBA的确切数量进行匹配
我已经search了谷歌以及堆栈，以下是我正在尝试完成的一些例子，虽然有一些很好的例子， 我有一些麻烦让我的代码工作，我需要的方式
在下表中我们有一个用户input（具有动物值）和相应的组ID的表格。 我想要做的是find组ID列中的唯一值，并用不同的数组进行交叉检查。 我现在的代码检查哪些数组共享相同的唯一值。
然而，正如你可以从我已经包含的图像告诉，我已经find了所有具有唯一值的数组共同的代码。 这将包括数组，其中所述唯一值是较大数组的子集。 我试图做的是find具有完全相同的唯一值的数组，没有什么比这更less; 当有一场比赛时; 某个子执行。
表格和数组如下所示： 
所以它背后的逻辑如下：
if array3 = arrayMain _ 'the array in the main table (orange then array3Query 'run sub linked to array 3 ... if array4 = arrayMain then array4Query 'run query linke to array 4 ... if array5 = arrayMain then array5query 'etc.. ... 以下是我目前的function：
Function UniqueVal(ByRef Arr1, ByRef Arr2) If TypeOf Arr1 Is Range Then Arr1 = Arr1.Value2 If TypeOf Arr2 Is Range Then Arr2 = Arr2.Value2 Dim e, x, i As Long With CreateObject("scripting.dictionary") .CompareMode = 1 For Each e In Arr1 If Len(e) Then .Item(e) = Empty Next For Each e In Arr2 If .Exists(e) Then .Item(e) = 1 Next x = Array(.Keys, .Items) .RemoveAll For i = 0 To UBound(x(0)) If x(1)(i) = 1 Then .Item(x(0)(i)) = Empty Next If .Count Then UniqueVal = .Keys End With End Function
而后者又被以下程序调用：
Sub iTestIntersection() MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("D2:D5")), vbLf) MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("F2:F7")), vbLf) MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("F10:F13")), vbLf) MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("D10:D12")), vbLf) '''''' End Sub
任何build议，我需要添加到上述function和或程序来完成我想要做的（当然减去消息框;只是试图运行子链接:)
如果Arr1不是一个数组，而是只有一个值，它将把这个值传递给ArrTemp(0)然后ReDim Arr1(0)将它变成一个空数组，最后它将原始值传递回Arr1(0) 。 可能有一个更容易/更好的方法来做到这一点，但我认为这将为你工作。 （我用一个名字来设置字典，这样我就可以更容易地进行debugging了。）
Function UniqueVal(ByRef Arr1, ByRef Arr2) Dim ArrTemp(0) Dim e, x, i As Long Dim xDictionary As Object If TypeOf Arr1 Is Range Then Arr1 = Arr1.Value2 If TypeOf Arr2 Is Range Then Arr2 = Arr2.Value2 If TypeName(Arr1) <> "Variant()" Then ArrTemp(0) = Arr1 ReDim Arr1(0) Arr1(0) = ArrTemp(0) End If Set xDictionary = CreateObject("Scripting.Dictionary") With xDictionary .CompareMode = 1 For Each e In Arr1 If Len(e) Then .Item(e) = Empty Next For Each e In Arr2 If .Exists(e) Then .Item(e) = 1 Else .RemoveAll UniqueVal = .Keys Exit Function End If Next x = Array(.Keys, .Items) .RemoveAll For i = 0 To UBound(x(0)) If x(1)(i) = 1 Then .Item(x(0)(i)) = Empty Else .RemoveAll UniqueVal = .Keys Exit Function End If Next If .Count Then UniqueVal = .Keys End With End Function