Compare 2 multi-arrays and isolate duplicate into 3rd array

[drex79]

Hello everyone,

I have been trying to find a solution to a problem where I have 2 multi dimensional arrays with duplicate data. I have found a lot of resources on how to eliminate duplicates, but nothing on how to isolate them (duplicates is the information i need).

I have a quick example of what I am referring to.





Sub my_test_array()
Dim arr1(1 To 9, 1 To 2) As Variant
Dim arr2(1 To 9, 1 To 2) As Variant
Dim arr3() As Variant 'dynamic based on number of duplicates

'arr1 data
'rownum
arr1(1, 2) = "158"
arr1(2, 2) = "159"
arr1(3, 2) = "160"
arr1(4, 2) = "161" '<--- dupe found in arr2
arr1(5, 2) = "162" '<--- dupe found in arr2
arr1(6, 2) = "163" '<--- dupe found in arr2
arr1(7, 2) = "164" '<--- dupe found in arr2
arr1(8, 2) = "165" '<--- dupe found in arr2
arr1(9, 2) = "166" '<--- dupe found in arr2
'time
arr1(1, 1) = "12:15"
arr1(2, 1) = "12:30"
arr1(3, 1) = "12:45"
arr1(4, 1) = "13:00"
arr1(5, 1) = "13:15"
arr1(6, 1) = "13:30"
arr1(7, 1) = "13:45"
arr1(8, 1) = "14:00"
arr1(9, 1) = "14:15"



'arr2 data
'rownum
arr2(1, 2) = "161" '<--- dupe found in arr1
arr2(2, 2) = "162" '<--- dupe found in arr1
arr2(3, 2) = "163" '<--- dupe found in arr1
arr2(4, 2) = "164" '<--- dupe found in arr1
arr2(5, 2) = "165" '<--- dupe found in arr1
arr2(6, 2) = "166" '<--- dupe found in arr1
arr2(7, 2) = "167"
arr2(8, 2) = "168"
arr2(9, 2) = "169"
'time
arr2(1, 1) = "13:00"
arr2(2, 1) = "13:15"
arr2(3, 1) = "13:30"
arr2(4, 1) = "13:45"
arr2(5, 1) = "14:00"
arr2(6, 1) = "14:15"
arr2(7, 1) = "14:30"
arr2(8, 1) = "14:45"
arr2(9, 1) = "14:45"


'compare arrays (assuming loop) and isolate duplicates in arr3




'expected data in arr3
'rownum
arr3(1, 2) = "161"
arr3(2, 2) = "162"
arr3(3, 2) = "163"
arr3(4, 2) = "164"
arr3(5, 2) = "165"
arr3(6, 2) = "166"
'time
arr3(1, 1) = "13:00"
arr3(2, 1) = "13:15"
arr3(3, 1) = "13:30"
arr3(4, 1) = "13:45"
arr3(5, 1) = "14:00"
arr3(6, 1) = "14:15"




End Sub





I have a complex method to finding a range of data of interest which is dumped into 2 separate arrays (arr1 and arr2). I had been looking for a way to merge the 2 (and found that vba has no native way of doing such a thing. I thought it may be easier to loop through arr2 with the first value (rownum) from arr1, but figured that would be pretty intensive as I will be doing this over and over.

Anyone have any ideas on how to find the duplicates belonging to arr1 and arr2 and isolate them into arr3?

Thanks in advance!

[SamT]

Arrays are uber fast. Dim arr3 the same as the others


k = LBound(arr1)
for i = LBound(arr1) to Ubound(arr1)
for j = LBound(arr2) to Ubound(arr2)
IF arr1(i, 2) = arr2(j, 2) then
arr3(k, 1) = arr2(j, 1)
arr3(k, 2) = arr2(j, 2)
k = k + 1
End If
Next
Next

k = Lbound(arr3)
Do
k = k + 1
Loop while arr(k,1) 'any number = true
Redim Preserve(arr3(k - Lbound(arr3)))

[drex79]

Thanks SamT,

I had came up with something similar and adjusted the rest of my code to ignore the blanks that mine would cause;


Erase arr3ReDim arr3(LBound(arr1) To UBound(arr2), 1 To 2) As Variant


For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
If arr1(i, 2) = arr2(j, 2) Then
arr3(i, 2) = arr1(i, 2)
arr3(i, 1) = arr1(i, 1)
End If
Next
Next

Technically, my problem would stem from arr1 and arr2 not being the same indexes (ie arr1 would be the row numbers, so arr1(158 To 166, 1 To 2) and arr1(161 To 169, 1 To 2) and not always be the same number of rows).

Ill check yours and get back to you! As always, thanks for the help (I actually used your last reference site to figure the above)!

[mikerickson]

ReDim Preserve only works to modify the last index of a multi dimensional array.

You might try something like this, note that Arr3 is initially dim as a transpose of arr1 and arr2.


Dim keyColumn As Variant
Dim Pointer As Long, i As Long

keyColumn = Application.Index(arr1, 0, 2)

ReDim arr3(1 To 2, 1 To (UBound(arr1, 1) + UBound(arr2, 1)))

For i = 1 To UBound(arr2, 1)
If IsNumeric(Application.Match(arr2(i, 2), keyColumn, 0)) Then
Pointer = Pointer + 1
arr3(1, Pointer) = arr2(i, 1)
arr3(2, Pointer) = arr2(i, 2)
End If
Next i

ReDim Preserve arr3(1 To 2, 1 To Pointer)

arr3 = Application.Transpose(arr3)