Question

我已经搜索了Google和Stack，以获取我在下面尝试完成的示例，虽然有一些类似的好例子;我在让代码按照我需要的方式工作时遇到了一些麻烦

在下表中，我们有一个包含用户输入（带有动物值）和相应组ID的表。我想要做的是在组ID列中找到唯一值，并用不同的数组交叉检查它们。我现在的代码检查以查看哪些数组共享相同的唯一值。

但是，正如你可以从我所包含的图像中看到的那样，我找到的代码中找到了具有共同唯一值的所有数组。这将包括数组，其中所述唯一值是较大数组的子集。我想要做的是找到具有完全相同的唯一值的数组，仅此而已;当有比赛时;某个子被执行。

表和数组如下所示：

所以它背后的逻辑如下：

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 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

关于我需要添加到上述函数和/或程序以完成我正在尝试做什么的任何建议（当然减去消息框;只是尝试运行链接到它的子：）

Answer 1

如果Arr1不是一个数组，但只有一个值，它会将该值传递给ArrTemp(0)，然后ReDim Arr1(0)将其转换为空数组，最后传递给它原始值回到Arr1(0)。可能有一种更容易/更好的方法来做到这一点，但我认为这对你有用。（我用一个名字设置字典，这样我就可以更容易地调试了。）

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

匹配具有确切数量的唯一值VBA的两个数组

1 个答案: