Create list of duplicated numbers
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. |
Create list of duplicated numbers
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 "J.W. Aldridge" wrote: 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. |
Create list of duplicated numbers
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 -- Regards, OssieMac "Mike H" wrote: 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 "J.W. Aldridge" wrote: 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. |
Create list of duplicated numbers
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. |
Create list of duplicated numbers
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. |
Create list of duplicated numbers
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" 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. |
Create list of duplicated numbers
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. |
All times are GMT +1. The time now is 04:48 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com