Question

I have been trying to figure this out for some time now. Originally I had searched Google and found some examples of (more or less) what I am trying to do, but seem to be stuck on the code I have thus far. Essentially I am trying to compare the unique variables between two arrays and return a result when there is a perfect match (if one possesses unique values there represent a subset of the other, this would not be a perfect match, all values and number of values would have to be identical.

From the code I have included below; if I compare one array [range("B2:b6") with values {1, 2, 3}] to a second array [(range("D10:D11") with values {1, 2}], I receive a positive match. Per what I am trying to do however (and value order doesn't matter) the only perfect match within an array of {1, 2, 3} would be a second array with values {1, 2, 3} also (or {3, 2, 1} as order doesn't matter).

I am guessing it is due to the type of array I am using and the fact that the lowerbound starts at 0. I could also be completely wrong. I have tried playing around with it without success.

Any Thoughts? Any suggestions are welcome. Thanks! (included pics with different values below)

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
            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
        Next
        If .Count Then UniqueVal = .Keys
    End With

End Function

'and the below sub which calls the above function

Sub iTestIntersectionX()

array4 = Join(UniqueVal(Worksheets("arrayTest2").Range("B2:B6"), Worksheets("arrayTest2").Range("D10:D11")), vbLf)
Worksheets("arrayTest2").Range("H20").value = array4

If Worksheets("arrayTest2").Range("H20").value <> "" Then
   MsgBox "Match Found!"
  Else
   MsgBox "No Match Found!"
End If

End Sub

Answer 1

如果传入的两个范围具有相同的唯一值集（以任何顺序或频率），则返回True

Function HaveSameValues(rng1 As Range, rng2 As Range)
Dim c As Range

    For Each c In rng1.Cells
        If Len(c.Value) > 0 And IsError(Application.Match(c.Value, rng2, 0)) Then
            SameValues = False
            Exit Function
        End If
    Next c
    For Each c In rng2.Cells
        If Len(c.Value) > 0 And IsError(Application.Match(c.Value, rng1, 0)) Then
            SameValues = False
            Exit Function
        End If
    Next c

    SameValues = True

End Function

Answer 2

您可以输入一个名为VLOOKUP的单元格。它需要几个参数。它在单元格列表中查找一个单元格的值，并返回单元格列表中匹配单元格旁边的单元格值。

Matching arrays with identical unique values VBA (Excel)

2 个答案: