As it hardly adds any extra time, might as well add the option to get the
produced duplicates
sorted by using another object in this dll, cSortedDictionary:
Public Function FindDupInArrays(arr1 As Variant, _
arr2 As Variant, _
Optional bUniqueDuplicatesOnly As Boolean, _
Optional bSortDuplicates As Boolean) As
Variant
'will take 2 1-based, 2-D, 1-column arrays
'and produce a 1-based, 2-D, 1-column array
'with the duplicates that are in the first 2 arrays
'optionally gets unique duplicates only and
'optionally sorts the produced duplicates
'--------------------------------------------------
Dim i As Long
Dim n As Long
Dim cCol1 As cCollection
Dim cColDup As cCollection
Dim cSDDup As cSortedDictionary
Dim arrDup
Set cCol1 = New cCollection
cCol1.CompatibleToVBCollection = False
cCol1.UniqueKeys = True
If bSortDuplicates Then
Set cSDDup = New cSortedDictionary
Else
Set cColDup = New cCollection
cColDup.CompatibleToVBCollection = False
cColDup.UniqueKeys = bUniqueDuplicatesOnly
End If
'add arr1 to cCol1
For i = 1 To UBound(arr1)
If cCol1.Exists(arr1(i, 1)) = False Then
n = n + 1
cCol1.Add n, arr1(i, 1)
End If
Next i
If bSortDuplicates Then
'add the duplicates to cSDDup
If bUniqueDuplicatesOnly Then
For i = 1 To UBound(arr2)
If cCol1.Exists(arr2(i, 1)) Then
If cSDDup.Exists(arr2(i, 1)) = False Then
cSDDup.Add arr2(i, 1), arr2(i, 1)
End If
End If
Next i
Else
cSDDup.UniqueKeys = False
For i = 1 To UBound(arr2)
If cCol1.Exists(arr2(i, 1)) Then
cSDDup.Add arr2(i, 1), arr2(i, 1)
End If
Next i
End If
If cSDDup.Count = 0 Then
FindDupInArrays = arrDup
Exit Function
End If
'transfer cSDDup to an array
ReDim arrDup(1 To cSDDup.Count, 1 To 1)
For i = 1 To cSDDup.Count
arrDup(i, 1) = cSDDup.ItemByIndex(i - 1)
Next i
Else 'If bSortDuplicates
'add the duplicates to cColDup
If bUniqueDuplicatesOnly Then
For i = 1 To UBound(arr2)
If cCol1.Exists(arr2(i, 1)) Then
If cColDup.Exists(arr2(i, 1)) = False Then
cColDup.Add arr2(i, 1), arr2(i, 1)
End If
End If
Next i
Else
For i = 1 To UBound(arr2)
If cCol1.Exists(arr2(i, 1)) Then
cColDup.Add arr2(i, 1)
End If
Next i
End If
If cColDup.Count = 0 Then
FindDupInArrays = arrDup
Exit Function
End If
'transfer cColDup to an array
ReDim arrDup(1 To cColDup.Count, 1 To 1)
For i = 1 To cColDup.Count
arrDup(i, 1) = cColDup.ItemByIndex(i - 1)
Next i
End If 'If bSortDuplicates
FindDupInArrays = arrDup
End Function
Test it like this, filling columns A and B with random numbers, by using a
formula like this:
= Int(Rand() * 1000000)
Note here that if no duplicates are found the result of FindDupInArrays
won't be an array, so
that is tested with the line:
If IsArray(arrDup) = False Then
Unless you are on a slow machine this should run in under one second:
Sub test()
Dim arr1
Dim arr2
Dim arrDup
Dim LR As Long
LR = 65536
arr1 = Range(Cells(1), Cells(LR, 1))
arr2 = Range(Cells(3), Cells(LR, 3))
arrDup = FindDupInArrays(arr1, arr2, False, True)
If IsArray(arrDup) = False Then
Exit Sub
End If
Range(Cells(5), Cells(65536, 5)).Clear
Range(Cells(5), Cells(UBound(arrDup), 5)) = arrDup
End Sub
RBS
"RB Smissaert" wrote in message
...
This works with the free dll dhRichClient3 from Olaf Schmidt
www.datenhaus.de/Downloads/dhRichClient3.zip
and will be very fast:
Function FindDups(arr1 As Variant, _
arr2 As Variant, _
Optional bUniqueDuplicatesOnly As Boolean) As Variant
'will take 2 1-based, 2-D, 1-column arrays
'and produce a 1-based, 2-D, 1-column array
'with the duplicates that are in the first 2 arrays
'optionally get unique duplicates only
'--------------------------------------------------
Dim i As Long
Dim n As Long
Dim cCol1 As cCollection
Dim colDup As cCollection
Dim arrDup
Set cCol1 = New cCollection
Set colDup = New cCollection
cCol1.CompatibleToVBCollection = False
cCol1.UniqueKeys = True
colDup.CompatibleToVBCollection = False
colDup.UniqueKeys = bUniqueDuplicatesOnly
'add arr1 to cCol1
For i = 1 To UBound(arr1)
If cCol1.Exists(arr1(i, 1)) = False Then
n = n + 1
cCol1.Add n, arr1(i, 1)
End If
Next i
'add the duplicates to colDup
If bUniqueDuplicatesOnly Then
For i = 1 To UBound(arr2)
If cCol1.Exists(arr2(i, 1)) Then
If colDup.Exists(arr2(i, 1)) = False Then
colDup.Add arr2(i, 1), arr2(i, 1)
End If
End If
Next i
Else
For i = 1 To UBound(arr2)
If cCol1.Exists(arr2(i, 1)) Then
colDup.Add arr2(i, 1)
End If
Next i
End If
If colDup.Count = 0 Then
FindDups = arrDup
Exit Function
End If
'transfer colDup to an array
ReDim arrDup(1 To colDup.Count, 1 To 1)
For i = 1 To colDup.Count
arrDup(i, 1) = colDup.ItemByIndex(i - 1)
Next i
FindDups = arrDup
End Function
Sub test()
Dim arr1
Dim arr2
Dim arrDup
arr1 = Range(Cells(1), Cells(65535, 1))
arr2 = Range(Cells(3), Cells(65535, 3))
arrDup = FindDups(arr1, arr2, True)
Range(Cells(5), Cells(UBound(arrDup), 5)) = arrDup
End Sub
You could do the same with the standard VB collection, but that will be
slower.
The above FindDup can run in less than a second, depending on the data in
the ranges.
RBS
"J.W. Aldridge" wrote in message
...
I have a string of data (numbers) starting in B6:B10000 and another
in
I6:I10000..
I need a code to search both strings and return any numbers that
appeared in both list. This list of duplicated numbers should start in
S6.