Same Contents, Regardless of Order

  • Thread starter Thread starter Gary''s Student
  • Start date Start date
G

Gary''s Student

I need a Boolean function that, given two input arrays of equal size, will
return TRUE if the contents of the arrays are the same (apart from order),
otherwise FALSE.

For example, if array 1 contained:
1,2,3,4
and array 2 contained:
2,3,1,4
then the function should return TRUE


If array 1 contained:
1,1,6,7
and array 2 contained:
7,1,6,2
then the function should return FALSE.
 
This should do it. The only way that I know of is a brute force attack.

Sub Test()
Dim ary1 As Variant
Dim ary2 As Variant
Dim ary3 As Variant
Dim ary4 As Variant

ary1 = Array(1, 2, 3, 4, 5, 6)
ary2 = Array(1, 6, 4, 3, 5, 2)
ary3 = Array(1, 1, 4, 3, 5, 2)
ary4 = Array(1, 2, 3, 4, 5, 6, 7)

MsgBox ArrayCompare(ary1, ary2)
MsgBox ArrayCompare(ary1, ary3)
MsgBox ArrayCompare(ary2, ary4)


End Sub


Public Function ArrayCompare(ByRef ary1 As Variant, ByRef ary2 As Variant)
As Boolean
Dim lngAry1 As Long
Dim lngAry2 As Long
Dim blnFound As Boolean

ArrayCompare = True
If UBound(ary1) <> UBound(ary2) Then
ArrayCompare = False
Exit Function
End If

blnFound = False
For lngAry1 = LBound(ary1) To UBound(ary1)
For lngAry2 = LBound(ary2) To UBound(ary2)
If ary1(lngAry1) = ary2(lngAry2) Then
blnFound = True
Exit For
End If
Next lngAry2
If blnFound = False Then
ArrayCompare = False
Exit For
End If
blnFound = False
Next lngAry1
End Function
 
Oops that does not quite work... Try this one...

Sub Test()
Dim ary1 As Variant
Dim ary2 As Variant
Dim ary3 As Variant
Dim ary4 As Variant

ary1 = Array(1, 2, 3, 4, 5, 6)
ary2 = Array(1, 6, 4, 3, 5, 2)
ary3 = Array(1, 1, 4, 3, 5, 2)
ary4 = Array(1, 2, 3, 4, 5, 6, 7)

MsgBox ArrayCompare(ary1, ary2)
MsgBox ArrayCompare(ary1, ary3)
MsgBox ArrayCompare(ary3, ary1)
MsgBox ArrayCompare(ary2, ary4)


End Sub


Public Function ArrayCompare(ByRef ary1 As Variant, ByRef ary2 As Variant)
As Boolean
Dim lngAry1 As Long
Dim lngAry2 As Long
Dim blnFound As Boolean

ArrayCompare = True
If UBound(ary1) <> UBound(ary2) Then
ArrayCompare = False
Exit Function
End If

blnFound = False
For lngAry1 = LBound(ary1) To UBound(ary1)
For lngAry2 = LBound(ary2) To UBound(ary2)
If ary1(lngAry1) = ary2(lngAry2) Then
blnFound = True
Exit For
End If
Next lngAry2
If blnFound = False Then
ArrayCompare = False
Exit Function
End If
blnFound = False
Next lngAry1

For lngAry2 = LBound(ary2) To UBound(ary2)
For lngAry1 = LBound(ary1) To UBound(ary1)
If ary1(lngAry1) = ary2(lngAry2) Then
blnFound = True
Exit For
End If
Next lngAry1
If blnFound = False Then
ArrayCompare = False
Exit Function
End If
blnFound = False
Next lngAry2
End Function
 
I get False with this set up...

Dim Arr1(4 To 7) As Long
Dim Arr2(7 To 10) As Long
Arr1(4) = 4
Arr1(5) = 2
Arr1(6) = 3
Arr1(7) = 1
Arr2(7) = 1
Arr2(8) = 2
Arr2(9) = 4
Arr2(10) = 3

Rick
 
This was a good problem! I'm almost completely sure<g> that this function
works correctly (with text or numeric arrays or Variant arrays containing
text or numeric values)...

Function IsSameContent(ByVal Arr1 As Variant, _
ByVal Arr2 As Variant) As Boolean
Dim X As Long
Dim Count() As Long
Dim ArrayString As String
If (VarType(Arr1) < vbArray) Or (VarType(Arr2) < vbArray) Or _
(UBound(Arr1) - LBound(Arr1) <> UBound(Arr2) - LBound(Arr2)) Then
Exit Function
End If
ReDim Count(0 To UBound(Arr1) - LBound(Arr1))
ArrayString = Chr$(1)
For X = LBound(Arr1) To UBound(Arr1)
ArrayString = CStr(ArrayString) & Arr1(X) & Chr$(1)
Next
IsSameContent = True
For X = LBound(Arr2) To UBound(Arr2)
If InStr(ArrayString, Chr$(1) & Arr2(X) & Chr$(1)) = 0 Then
IsSameContent = False
Exit Function
Else
ArrayString = Replace(ArrayString, Arr2(X), "", , 1)
End If
Next
End Function


Rick
 
Changing this line...

If UBound(ary1) <> UBound(ary2) Then

to this line...

If UBound(ary1) - LBound(ary1) <> UBound(ary2) - LBound(ary2) Then

appears to correct the problem.

Rick
 
Thanks...I was sorting the arrays and then comparing them item-by-item.

Both your code and Jim's were mush faster than mine.
 
I think I spotted a flaw in Jim's method. Try this subroutine with Jim's
function (I get it to return True even though the two arrays are clearly
different)...

Sub Test()
Dim Arr1(0 To 3) As Variant
Dim Arr2(0 To 3) As Variant
' First Array
Arr1(0) = 4
Arr1(1) = 4
Arr1(2) = 3
Arr1(3) = 1
' Second Array
Arr2(0) = 1
Arr2(1) = 3
Arr2(2) = 4
Arr2(3) = 3
Debug.Print ArrayCompare(Arr1, Arr2)
End Sub

Rick
 
This was a good problem! I'm almost completely sure<g> that this function
works correctly (with text or numeric arrays or Variant arrays containing
text or numeric values)...

Function IsSameContent(ByVal Arr1 As Variant, _
ByVal Arr2 As Variant) As Boolean
Dim X As Long
Dim Count() As Long
Dim ArrayString As String
If (VarType(Arr1) < vbArray) Or (VarType(Arr2) < vbArray) Or _
(UBound(Arr1) - LBound(Arr1) <> UBound(Arr2) - LBound(Arr2)) Then
Exit Function
End If
ReDim Count(0 To UBound(Arr1) - LBound(Arr1))
ArrayString = Chr$(1)
For X = LBound(Arr1) To UBound(Arr1)
ArrayString = CStr(ArrayString) & Arr1(X) & Chr$(1)
Next
IsSameContent = True
For X = LBound(Arr2) To UBound(Arr2)
If InStr(ArrayString, Chr$(1) & Arr2(X) & Chr$(1)) = 0 Then
IsSameContent = False
Exit Function
Else
ArrayString = Replace(ArrayString, Arr2(X), "", , 1)
End If
Next
End Function


Rick
Click to expand...

Rick,

I've been fooling around with this, and with my own version which sorts the
array and then compares item for item. And I ran into an issue (XL2007)
whereby if the arguments for the function is a range reference, rather than an
array constant, then the function fails. In particular, it fails when trying
to use the Ubound method, since the argument is an object. This is true even
when passing the argument ByVal.

I worked around this by testing to see if the argument was an object or not,
and using the Count property if it was an object, but I wonder if there is a
more efficient method.

Any thoughts?

(I did not bother to test, as you did, to make sure that the references passed
were arrays -- being OK with the #VALUE! error being returned in that
instance).

Also, whether the argument being passed was an array constant, or a range
reference, the vartype was 8204.

Here's my effort. I used a simple Bubblesort routine, although I know there
are faster algorithms.

=======================================
Function CompArr(ByVal Array1, ByVal Array2) As Boolean
Dim a1 As Variant, a2 As Variant

a1 = Extract(Array1)
a2 = Extract(Array2)

CompArr = True

If UBound(a1) <> UBound(a2) Then
CompArr = False
Exit Function
End If

BubbleSort a1
BubbleSort a2

For i = 1 To UBound(a1)
If a1(i) <> a2(i) Then
CompArr = False
Exit Function
End If
Next i
End Function
Private Sub BubbleSort(TempArray As Variant)
Dim temp As Variant
Dim i As Integer
Dim NoExchanges As Integer

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
For i = 1 To UBound(TempArray) - 1

' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(i) > TempArray(i + 1) Then
NoExchanges = False
temp = TempArray(i)
TempArray(i) = TempArray(i + 1)
TempArray(i + 1) = temp
End If
Next i
Loop While Not (NoExchanges)
End Sub
Private Function Extract(a) As Variant
Dim o As Object
Dim i As Long
Dim temp() As Variant

If IsObject(a) Then
ReDim temp(1 To a.Count)
For i = 1 To a.Count
temp(i) = a(i)
Next i
Else
ReDim temp(1 To UBound(a))
For i = 1 To UBound(a)
temp(i) = a(i)
Next i
End If
Extract = temp
End Function
==================================
--ron
 
I worked around this by testing to see if the argument was an object or not,
and using the Count property if it was an object, but I wonder if there is a
more efficient method.
Click to expand...

Actually, the Extract function can be simplified:

=======================
Private Function Extract(a) As Variant
Dim i As Long
Dim temp() As Variant

If IsObject(a) Then
ReDim temp(1 To a.Count)
For i = 1 To a.Count
temp(i) = a(i)
Next i
Extract = temp
Else
Extract = a
End If
End Function
=========================
--ron
 
This is very interesting!!

I guess the reason I did not hit a problem was that I did the sorts in-line
rather than thru another function call.

In any case, I like your bi-directional cross-check much better.

Thanks again!!
 
This is very interesting!!

I guess the reason I did not hit a problem was that I did the sorts in-line
rather than thru another function call.

In any case, I like your bi-directional cross-check much better.

Thanks again!!
Click to expand...

Gary''s Student,

I'm not sure if you are responding to me or to Rick. But if to me, how is the
speed of my routine on your data compared with the others?

Is it worthwhile coding a faster sort routine?

Thanks.

--ron
--ron
 
This is very interesting!!
Gary''s Student,

I'm not sure if you are responding to me or to Rick.
Click to expand...

I don't think he is referring to me as I don't use a "bi-directional
cross-check", although I didn't think you did either.<g>

By the way, I get an incorrect False returned for the following set up using
"normal" arrays (not Range references)...

Dim Arr1(0 To 3) As Variant
Dim Arr2(0 To 3) As Variant
Arr1(0) = 4
Arr1(1) = 2
Arr1(2) = 3
Arr1(3) = 1
Arr2(0) = 1
Arr2(1) = 3
Arr2(2) = 4
Arr2(3) = 2
Debug.Print CompArr(Arr1, Arr2)

A quick look seems to indicate the problem is stemming from your use of 1 as
the assumed lower bound for the arrays. I would think using
LBound(WhicheverArray) would solve the problem with respect to the above,
but doing so might adversely impact your attempt to handle Range References
(which I guess you are doing with the assumption the function might be used
as a UDF... something I did not consider would be done in my code).

Rick
 
I don't think he is referring to me as I don't use a "bi-directional
cross-check", although I didn't think you did either.<g>

By the way, I get an incorrect False returned for the following set up using
"normal" arrays (not Range references)...

Dim Arr1(0 To 3) As Variant
Dim Arr2(0 To 3) As Variant
Arr1(0) = 4
Arr1(1) = 2
Arr1(2) = 3
Arr1(3) = 1
Arr2(0) = 1
Arr2(1) = 3
Arr2(2) = 4
Arr2(3) = 2
Debug.Print CompArr(Arr1, Arr2)

A quick look seems to indicate the problem is stemming from your use of 1 as
the assumed lower bound for the arrays. I would think using
LBound(WhicheverArray) would solve the problem with respect to the above,
but doing so might adversely impact your attempt to handle Range References
(which I guess you are doing with the assumption the function might be used
as a UDF... something I did not consider would be done in my code).

Rick
Click to expand...

Well, I didn't consider that zero-based arrays would be arriving to my code
<g>, but you're correct, the problem is easily handled by changing all
references to "1" to "Lbound(array)".

I was using one to handle the instance of array-constants, where a=Array1
results in a 1-based array, if Array1 is an array constant.

So, I think this should handle both situations:

==================================
Function CompArr(ByVal Array1, ByVal Array2) As Boolean
Dim a1 As Variant, a2 As Variant

a1 = Extract(Array1)
a2 = Extract(Array2)

CompArr = True

If UBound(a1) <> UBound(a2) Then
CompArr = False
Exit Function
End If

BubbleSort a1
BubbleSort a2

For i = LBound(a1) To UBound(a1)
If a1(i) <> a2(i) Then
CompArr = False
Exit Function
End If
Next i
End Function
Private Sub BubbleSort(TempArray As Variant)
Dim temp As Variant
Dim i As Integer
Dim NoExchanges As Integer

' Loop until no more "exchanges" are made.
Do
NoExchanges = True

' Loop through each element in the array.
For i = LBound(TempArray) To UBound(TempArray) - 1

' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(i) > TempArray(i + 1) Then
NoExchanges = False
temp = TempArray(i)
TempArray(i) = TempArray(i + 1)
TempArray(i + 1) = temp
End If
Next i
Loop While Not (NoExchanges)
End Sub
Private Function Extract(a) As Variant
Dim i As Long
Dim temp() As Variant

If IsObject(a) Then
ReDim temp(1 To a.Count)
For i = 1 To a.Count
temp(i) = a(i)
Next i
Extract = temp
Else
Extract = a
End If
End Function
================================
--ron
 
Back
Top