Create list of duplicated numbers

[J.W. Aldridge]

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.

 

[Mike H]

Hi,

Probably not the most effecient but try this

Sub marine()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim MyRange1 As Range
Dim MyRange2 As Range
x = 6
Set MyRange1 = Range("B6:B10000")
Set MyRange2 = Range("I6:I10000")
For Each c In MyRange1.Cells
For Each d In MyRange2.Cells
If c.Value = d.Value Then
Cells(x, 19).Value = c.Value
x = x + 1
Exit For
End If
Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Mike

 

[OssieMac]

I think that would take forever to run Mike. 10,000 X 10,000 loops. The
following modification has only 10,000 loops. I tested the time taken and it
makes no real difference with screenupdating and calculation turned off.

Sub marine()

Dim MyRange1 As Range
Dim MyRange2 As Range
Dim c As Range
Dim x As Double

x = 6
Set MyRange1 = Range("B6:B10000")
Set MyRange2 = Range("I6:I10000")
For Each c In MyRange1.Cells
If WorksheetFunction.CountIf(MyRange2, c.Value) > 0 Then
Cells(x, "S") = c.Value
x = x + 1
End If
Next c

End Sub

 

[Spiggy Topes]

Another approach would be to clone the ranges to a separate sheet,
sort both lists into ascending order, then a single pass through the
sheet as follows:

Option Explicit
Sub doit()
Dim i As Integer
Dim j As Integer
Dim k As Integer

i = 1
j = 1
k = 1

Do While i <= ActiveSheet.UsedRange.Rows.Count And j <=
ActiveSheet.UsedRange.Rows.Count
Select Case Cells(i, 1) - Cells(j, 2)
Case Is < 0
i = i + 1
Case Is > 0
j = j + 1
Case Else
Cells(k, 3) = Cells(i, 1)
i = i + 1
j = j + 1
k = k + 1
End Select
Loop
End Sub

I leave you to fill in the clone process, adjust column numbers,
identify the sheet for the destination cell and delete the cloned
sheet once you're done. Note that you didn't specify what to do with
multiple occurrences in each column; if the number 17, say, occurs
once in one column and three times in the other, this code will
identify one match only; if the same number occurs three times in each
column, then you'll get three matches. Easy enough to tweak to
eliminate duplicate matches if needed.

 

[RB Smissaert]

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

 

[RB Smissaert]

Forgot to say that the function FindDups will run about twice as fast if it
is compiled to a dll in VB6 with all fast compiler options, so no array
bounds
checking etc.

RBS

 

[RB Smissaert]

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