Find matches in 2 cols using Collection vs Dictionary

G

GS

I've been working on this with Ron Rosefeld and Jim Cone to find an
optimum solution. I'm pleased to provide the following function for
review/testing/feedback.

The test data was 2 cols by 500,000 rows of random generated numbers
formatted as "0000000000000" so we'd have leading zeros.

The test machine is a 1.6Ghz dual core Dell Precision series laptop
running XP SP3 and Excel2007. Times are approximate, as per method
shown in function, and are as follows:

Allow duplicate values: 9secs
Allow unique values: 10secs

This is a considerable performance improvement over using Dictionary,
plus no ref to the Microsoft Scripting Runtime is needed.

I'd be pleased to here results from running this on other machines.
Here's the code I used to set up the data...


Sub Setup_Data_StripDupes()
With Range("A1:B500000")
.Formula = "=text(randbetween(1,10^6),""0000000000000"")"
.Value = .Value
End With
End Sub


Function StripDupes(Optional AllowDupes As Boolean = True) As Boolean
' Compares colA to colB and removes colA matches found in colB.
' Args In: AllowDupes: True by default. Keeps duplicate values
' found in colA that are not found in colB. If False,
' duplicate values in colA not found in colB are removed.
'
' Returns: True if matches found and no error occurs;
' False if matches not found --OR-- error occurs.
'
' Sources: Ron Rosenfeld, Jim Cone, Garry Sansom

Dim i&, j&, lMatchesFound& 'as long
Dim vRngA, vRngB, vRngOut() 'as variant

vRngA = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
vRngB = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)

Debug.Print Now()
Dim dRngB As New Collection
On Error Resume Next
For j = LBound(vRngB) To UBound(vRngB)
dRngB.Add Key:=CStr(vRngB(j, 1)), Item:=CStr(vRngB(j, 1))
Next 'j
Err.Clear: On Error GoTo ErrExit

If AllowDupes Then '//fastest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
If dRngB.Item(CStr(vRngA(i, 1))) <> "" Then _
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1
skipit:
Next 'i

Else '//slowest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
dRngB.Add Key:=CStr(vRngA(i, 1)), Item:=CStr(vRngA(i, 1))
Next 'i
End If 'AllowDupes
Err.Clear: On Error GoTo ErrExit

j = 0: ReDim vRngOut(UBound(vRngA) - lMatchesFound, 0)
For i = LBound(vRngA) To UBound(vRngA)
If Not vRngA(i, 1) = "" Then _
vRngOut(j, 0) = vRngA(i, 1): j = j + 1
Next 'i

Range("A1:A" & lRows1).ClearContents
Range("A1").Resize(UBound(vRngOut), 1) = vRngOut
Debug.Print Now()

ErrExit:
StripDupes = (Err = 0)
Exit Function

MatchFound:
If AllowDupes Then Resume skipit
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1: Resume Next

End Function 'StripDupes()
 
G

GS

Ron Rosenfeld, I apologize for mis-spelling your name. (I hate when the
keys I press don't press! Ugh!)
 
R

Ron Rosenfeld

Ron Rosenfeld, I apologize for mis-spelling your name. (I hate when the
keys I press don't press! Ugh!)
Click to expand...

It happens to some even when speaking! No apologies necessary. Besides, I didn't even notice :)
 
R

Ron Rosenfeld

The test machine is a 1.6Ghz dual core Dell Precision series laptop
running XP SP3 and Excel2007. Times are approximate, as per method
shown in function, and are as follows:

Allow duplicate values: 9secs
Allow unique values: 10secs

This is a considerable performance improvement over using Dictionary,
plus no ref to the Microsoft Scripting Runtime is needed.

I'd be pleased to here results from running this on other machines.
Here's the code I used to set up the data...
Click to expand...

The number of results returned also affects the speed.
But your routine would not run on my machine as written.

1. Your Function StripDupes is attempting to write to a range. In VBA, a Function can only return a value; it cannot alter anything on the sheet.
2. You have an undeclared variable in StripDupes. I would suggest using Option Explicit to prevent that. If you set your options to Require Variable Declaration, Option Explicit will be inserted when you Insert/Module
3. Changing your Function to a "Sub", making some other required changes, and using the Hi Res Timer; I get the following results:

Time: 6.443 Error: 1004 Allow Dupes: True Count: 303,299
Time: 7.488 Error: 1004 Allow Dupes: False Count: 238,713

and on a second run in reverse order:

Time: 7.497 Error: 1004 Allow Dupes: False Count: 238,713
Time: 6.407 Error: 1004 Allow Dupes: True Count: 303,299

I'll let you troubleshoot the error.

Here is your modified Strip Dupes. I left in my timing code so you could see where I placed the timing points. Obviously, that should be removed.
My PruneColA2, equivalent to your StripDupes(False), runs slightly slower at 7.9

=====================================
Sub StripDupes(Optional AllowDupes As Boolean = True)
' Compares colA to colB and removes colA matches found in colB.
' Args In: AllowDupes: True by default. Keeps duplicate values
' found in colA that are not found in colB. If False,
' duplicate values in colA not found in colB are removed.
'
' Returns: True if matches found and no error occurs;
' False if matches not found --OR-- error occurs.
'
' Sources: Ron Rosenfeld, Jim Cone, Garry Sansom

Dim oTimer As ronslibrary.CHiResTimer
Set oTimer = ronslibrary.New_CHiResTimer
oTimer.StartTimer

Dim i&, j&, lMatchesFound& 'as long
Dim vRngA, vRngB, vRngOut() 'as variant
Dim lRows1

vRngA = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
vRngB = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)

'Debug.Print Now()
Dim dRngB As New Collection
On Error Resume Next
For j = LBound(vRngB) To UBound(vRngB)
dRngB.Add Key:=CStr(vRngB(j, 1)), Item:=CStr(vRngB(j, 1))
Next 'j
Err.Clear: On Error GoTo ErrExit

If AllowDupes Then '//fastest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
If dRngB.Item(CStr(vRngA(i, 1))) <> "" Then _
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1
skipit:
Next 'i

Else '//slowest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
dRngB.Add Key:=CStr(vRngA(i, 1)), Item:=CStr(vRngA(i, 1))
Next 'i
End If 'AllowDupes
Err.Clear: On Error GoTo ErrExit

j = 0: ReDim vRngOut(UBound(vRngA) - lMatchesFound, 0)
For i = LBound(vRngA) To UBound(vRngA)
If Not vRngA(i, 1) = "" Then _
vRngOut(j, 0) = vRngA(i, 1): j = j + 1
Next 'i

Range("A1:A" & lRows1).ClearContents
Range("A1").Resize(UBound(vRngOut), 1) = vRngOut
'Debug.Print Now()

ErrExit:
oTimer.StopTimer
Debug.Print "Time: " & Format(oTimer.Elapsed, "0.000"), "Error: " & _
Err, "Allow Dupes: " & AllowDupes, "Count: " & Format(UBound(vRngOut), "#,###")
Exit Sub

MatchFound:
If AllowDupes Then Resume skipit
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1: Resume Next

End Sub 'StripDupes()
==================================
 
G

GS

Ron,
The function is NOT designed to be used as a worksheet function, but
rather by VBA as follows...

If Not StripDupes Then MsgBox "Error!" Else RunSomeOtherCode
 
G

GS

Thanks for catching the undeclared var. I forgot to modify the line
using it as intended. (Too old to work past being tired anymore!<g>)

I'm pleased that it performs nearly as well as yours did (assuming
tests were same). Here's a revised version prefaced by example usage:

Sub DoStuff()
If StripDupes then Call RunSomeProcess
End Sub 'DoStuff

Function StripDupes(Optional AllowDupes As Boolean = True) As Boolean
' Compares colA to colB and removes colA matches found in colB.
' Args In: AllowDupes: True by default. Keeps duplicate values
' found in colA that are not found in colB. If False,
' duplicate values in colA not found in colB are removed.
'
' Returns: True if matches found and no error occurs;
' False if matches not found --OR-- error occurs.
'
' Sources: Ron Rosenfeld, Jim Cone, Garry Sansom

Dim i&, j&, lMatchesFound& 'as long
Dim vRngA, vRngB, vRngOut() 'as variant

vRngA = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
vRngB = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)

Debug.Print Now()
Dim dRngB As New Collection
On Error Resume Next
For j = LBound(vRngB) To UBound(vRngB)
dRngB.Add Key:=CStr(vRngB(j, 1)), Item:=CStr(vRngB(j, 1))
Next 'j
Err.Clear: On Error GoTo ErrExit

If AllowDupes Then '//fastest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
If dRngB.Item(CStr(vRngA(i, 1))) <> "" Then _
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1
skipit:
Next 'i

Else '//slowest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
dRngB.Add Key:=CStr(vRngA(i, 1)), Item:=CStr(vRngA(i, 1))
Next 'i
End If 'AllowDupes
Err.Clear: On Error GoTo ErrExit

j = 0: ReDim vRngOut(UBound(vRngA) - lMatchesFound, 0)
For i = LBound(vRngA) To UBound(vRngA)
If Not vRngA(i, 1) = "" Then _
vRngOut(j, 0) = vRngA(i, 1): j = j + 1
Next 'i

Range("A:A").ClearContents
Range("A1").Resize(UBound(vRngOut), 1) = vRngOut
Debug.Print Now()

ErrExit:
If lMatchesFound = 0 Then
StripDupes = False: MsgBox "No matches were found"
Else
StripDupes = (Err = 0)
End If 'lMatchesFound = 0
Exit Function

MatchFound:
If AllowDupes Then Resume skipit
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1: Resume Next

End Function 'StripDupes()
 
G

GS

After a bit more thought I decided the StripDupes function should NOT
include any error notification from within, so this can be handled by
the caller...

Caller:
Sub Test_StripDupes()
Dim bSuccess As Boolean, lMatchesFound& 'as long

bSuccess = StripDupes(lMatchesFound) '//allow dupes in new list
' bSuccess = StripDupes(lMatchesFound, False) '//no dupes in new list

Select Case bSuccess
Case Is = False
If lMatchesFound = 0 Then MsgBox "No matches found!" _
Else MsgBox "An error occured!"

Case Is = True
If lMatchesFound = 0 Then
MsgBox "No matches found!"
Else
MsgBox Format(CStr(lMatchesFound), "#,##0") _
& " Matches were found"
'Code goes here to call some other process to act on new list
End If 'lMatchesFound = 0
End Select 'Case bSuccess
End Sub

Results:
True call on new data: "196,484 matches found"
Repeat True call on above call's list: "No matches were found"
False call on above call's list: "64,495 matches were found"
Repeat False call on above call's list: "No matches were found"
Repeat True call on above call's list: "No matches were found"

**Note that the matches found on the False call are additional after
running the True call first. Otherwise, running the False call first
would have returned the sum of both matches found**


Revised function:
Function StripDupes(Matches As Long, _
Optional AllowDupes As Boolean = True) As Boolean
' Compares colA to colB and removes colA matches found in colB.
'
' Args In: Matches: ByRef var to return number of matches found to
' the caller.
'
' AllowDupes: True by default. Keeps duplicate values
' found in colA that are not found in colB. If False,
' duplicate values in colA not found in colB are removed.
'
' Returns: True if matches found and no error occurs;
' False if matches not found --OR-- error occurs.
'
' Sources: Ron Rosenfeld, Jim Cone, Garry Sansom

Dim i&, j&, lMatchesFound& 'as long
Dim vRngA, vRngB, vRngOut() 'as variant

vRngA = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
vRngB = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)

Debug.Print Now()
Dim dRngB As New Collection
On Error Resume Next
For j = LBound(vRngB) To UBound(vRngB)
dRngB.Add Key:=CStr(vRngB(j, 1)), Item:=CStr(vRngB(j, 1))
Next 'j
Err.Clear: On Error GoTo ErrExit

If AllowDupes Then '//fastest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
If dRngB.Item(CStr(vRngA(i, 1))) <> "" Then _
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1
skipit:
Next 'i

Else '//slowest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
dRngB.Add Key:=CStr(vRngA(i, 1)), Item:=CStr(vRngA(i, 1))
Next 'i
End If 'AllowDupes
Err.Clear: On Error GoTo ErrExit

j = 0: ReDim vRngOut(UBound(vRngA) - lMatchesFound, 0)
For i = LBound(vRngA) To UBound(vRngA)
If Not vRngA(i, 1) = "" Then _
vRngOut(j, 0) = vRngA(i, 1): j = j + 1
Next 'i

Range("A:A").ClearContents
Range("A1").Resize(UBound(vRngOut), 1) = vRngOut
Debug.Print Now()

ErrExit:
Matches = lMatchesFound: StripDupes = (Err = 0)
Exit Function

MatchFound:
If AllowDupes Then Resume skipit
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1: Resume Next

End Function 'StripDupes()
 
G

GS

I've condensed the test caller procedure as follows...

Sub Test_StripDupes()
Dim bSuccess As Boolean, lMatchesFound& 'as long

bSuccess = StripDupes(lMatchesFound) '//allow dupes in new list
' bSuccess = StripDupes(lMatchesFound, False) '//no dupes in new list

If lMatchesFound = 0 Then MsgBox "No matches found!": Exit Sub
If Not bSuccess Then
MsgBox "An error occured!"
Else
MsgBox Format(CStr(lMatchesFound), "#,##0") _
& " Matches were found"
'Code goes here to call some other process to act on new list
End If 'Not bSuccess
End Sub
 
R

Ron Rosenfeld

Ron,
The function is NOT designed to be used as a worksheet function, but
rather by VBA as follows...

If Not StripDupes Then MsgBox "Error!" Else RunSomeOtherCode
Click to expand...

My understanding is that doesn't matter. Your Function is still trying to modify worksheet cells, and that is probably where the error is coming from. Do you actually see the worksheet cells being written to when you run that function?
 
G

GS

My understanding is that doesn't matter. Your Function is still trying to
modify worksheet cells, and that is probably where the error is coming from.
Do you actually see the worksheet cells being written to when you run that
function?
Click to expand...

Yes, the results edit the original list (colA).
Is this issue about my function modifying cells an unspoken or
undocumented rule? How are you using the function?
 
G

GS

Ron Rosenfeld used his keyboard to write :
My understanding is that doesn't matter. Your Function is still trying to
modify worksheet cells, and that is probably where the error is coming from.
Do you actually see the worksheet cells being written to when you run that
function?
Click to expand...

My understanding of a function is that it's used when a return is
needed. There is no difference, otherwise, between a function and a
sub.

My understanding of a UDF is that it can't modify cells if called from
a worksheet cell formula. This definitely DOES NOT apply to VBA
functions called by VBA procedures (function or sub).
 
R

Ron Rosenfeld

Yes, the results edit the original list (colA).
Is this issue about my function modifying cells an unspoken or
undocumented rule? How are you using the function?
Click to expand...


I copied and pasted your setup and function routines.
After running your setup routine, and declaring the undeclared variable in your function, I used your function in a sub:

Sub foo()
Debug.Print StripDupes()
End Sub

It changed NOTHING on the worksheet.
It returned:

1/17/2012 4:28:57 PM
False

which is the start time and the error exit.

Troubleshooting with break points showed it was a 1004 error and that the error was triggered by

Range("A1:A" & lRows1).ClearContents

which, I believe, is the first line your sub that tries to alter the worksheet.

This is congruent with my understanding of how a Function works in Excel.
 
G

GS

Please change to the 'fixed' version I posted (time stamped 10:06:54
AM)
which was my rep;y to your 2nd listed post time stamped 7:53:31 AM.
 
G

GS

GS brought next idea :
Please change to the 'fixed' version I posted (time stamped 10:06:54 AM)
which was my rep;y to your 2nd listed post time stamped 7:53:31 AM.
Click to expand...

That would be my 2nd reply to your 2nd listed post.
 
R

Ron Rosenfeld

Please change to the 'fixed' version I posted (time stamped 10:06:54
AM)
which was my rep;y to your 2nd listed post time stamped 7:53:31 AM.
Click to expand...

Hmmm. Well I am surprised. I did not realize there was that difference between a function called from a sub in VBA, and from the workbook. Perhaps I was confused with having a function in a workbook calling a sub to modify a cell on the worksheet, and that not working. In any event, it is a learning experience for me.
 
G

GS

In an effort to make this function more 'functional', I've modified it
so the user can specify the col to remove dupes from along with the col
to check AND the col where to put the revised list. This should qualify
this as a reusable utility users can run from PERSONAL.XLS or a
utilities addin if they have one.

The caller routine:
Sub CompareCols_StripDupes()
Dim bSuccess As Boolean, lMatchesFound& 'as long
Dim vAns As Variant, sMsg As String

sMsg = _
"Do you want to remove any duplicate items in the non-matches?" _
& vbLf & "(Doing so will return a list of unique items)"
vAns = MsgBox(sMsg, vbYesNo + vbQuestion)

If vAns = vbNo Then
bSuccess = StripDupes(lMatchesFound) '//dupes allowed
Else
bSuccess = StripDupes(lMatchesFound, False) '//no dupes allowed
End If 'vAns = vbNo

If lMatchesFound = 0 Then MsgBox "No matches found!": Exit Sub
If lMatchesFound < 0 Then
sMsg = "Both columns must have more than 1 item!" _
& vbLf & vbLf & "Please try again: specify different columns!"
MsgBox sMsg, vbExclamation
Exit Sub
End If 'lMatchesFound < 0

If bSuccess Then
sMsg = Format(CStr(lMatchesFound), "#,##0") _
& " Matches were found"
If vAns = vbYes Then _
sMsg = sMsg & " (including non-match duplicates)"
MsgBox sMsg
'Code goes here to call some other process to act on new list
Else
MsgBox "An error occured!"
End If 'bSuccess
End Sub


The new StripDupes() function:
Function StripDupes(Matches As Long, _
Optional AllowDupes As Boolean = True) As Boolean
' Compares 2 user-specified cols and removes matches found.
' User can also specific target col to receive revised list.
'
' Args In: Matches: ByRef var to return number of matches found to
' the caller.
'
' AllowDupes: True by default. Keeps duplicate non-match
' values in col to remove dupes from. If passing False,
' duplicate items in non-match col are removed.
'
' Returns: True if matches found and no error occurs;
' False if a: matches not found --OR-- error occurs;
' b: either input col has less than 2 items.
'
' Sources: Ron Rosenfeld, Jim Cone, Garry Sansom
''''''''''

Dim i&, j&, lMatchesFound& 'as long
Dim vRngA, vRngB, vRngOut(), vAns 'as variant
Dim sRngOut As String

'Get the label of the columns to act on
Const sMsg As String = "Please enter the label of the column"
'Column to filter
vAns = Application.InputBox(sMsg _
& " to remove duplicates from", Type:=2)
If Not vAns Or vAns = "" Then Exit Function
vRngA = Range(vAns & "1:" & vAns _
& Cells(Rows.Count, vAns).End(xlUp).Row)
sRngOut = vAns '//output goes here unless specified below
'Column to be checked
vAns = Application.InputBox(sMsg _
& " to check for duplicates", Type:=2)
If Not vAns Or vAns = "" Then Exit Function
vRngB = Range(vAns & "1:" & vAns _
& Cells(Rows.Count, vAns).End(xlUp).Row)

'Make sure lists contain more than 1 item
If Not IsArray(vRngA) Or Not IsArray(vRngB) Then _
Matches = -1: Exit Function

'Column to receive the results
vAns = Application.InputBox(sMsg _
& "where the new list is to go" & vbLf _
& "(Leave blank or click 'Cancel' to use column " _
& UCase$(sRngOut) & ")", Type:=2)
If Not vAns Or vAns = "" Then sRngOut = sRngOut _
Else sRngOut = vAns

'Debug.Print Now()
Dim dRngB As New Collection
On Error Resume Next
For j = LBound(vRngB) To UBound(vRngB)
dRngB.Add Key:=CStr(vRngB(j, 1)), Item:=CStr(vRngB(j, 1))
Next 'j
Err.Clear: On Error GoTo ErrExit

If AllowDupes Then '//fastest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
If dRngB.Item(CStr(vRngA(i, 1))) <> "" Then _
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1
skipit:
Next 'i

Else '//slowest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
dRngB.Add Key:=CStr(vRngA(i, 1)), Item:=CStr(vRngA(i, 1))
Next 'i
End If 'AllowDupes
Err.Clear: On Error GoTo ErrExit

j = 0: ReDim vRngOut(UBound(vRngA) - lMatchesFound, 0)
For i = LBound(vRngA) To UBound(vRngA)
If Not vRngA(i, 1) = "" Then _
vRngOut(j, 0) = vRngA(i, 1): j = j + 1
Next 'i

Range(sRngOut & ":" & sRngOut).ClearContents
With Range(sRngOut & "1").Resize(UBound(vRngOut), 1)
.NumberFormat = "0000000000000": .Value = vRngOut:
..EntireColumn.AutoFit
End With
'Debug.Print Now()

ErrExit:
Matches = lMatchesFound: StripDupes = (Err = 0)
Exit Function

MatchFound:
If AllowDupes Then Resume skipit
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1: Resume Next

End Function 'StripDupes()
 
G

GS

Just a text wrap fix near end of the function where it writes to the
output column...

Function StripDupes(Matches As Long, _
Optional AllowDupes As Boolean = True) As Boolean
' Compares 2 user-specified cols and removes matches found.
' User can also specific target col to receive revised list.
'
' Args In: Matches: ByRef var to return number of matches found to
' the caller.
'
' AllowDupes: True by default. Keeps duplicate non-match
' values in col to remove dupes from. If passing False,
' duplicate items in non-match col are removed.
'
' Returns: True if matches found and no error occurs;
' False if a: matches not found --OR-- error occurs;
' b: either input col has less than 2 items.
'
' Sources: Ron Rosenfeld, Jim Cone, Garry Sansom

Dim i&, j&, lMatchesFound& 'as long
Dim vRngA, vRngB, vRngOut(), vAns 'as variant
Dim sRngOut As String

'Get the label of the columns to act on
Const sMsg As String = "Please enter the label of the column"
'Column to filter
vAns = Application.InputBox(sMsg _
& " to remove duplicates from", Type:=2)
If Not vAns Or vAns = "" Then Exit Function
vRngA = Range(vAns & "1:" & vAns _
& Cells(Rows.Count, vAns).End(xlUp).Row)
sRngOut = vAns '//output goes here unless specified below
'Column to be checked
vAns = Application.InputBox(sMsg _
& " to check for duplicates", Type:=2)
If Not vAns Or vAns = "" Then Exit Function
vRngB = Range(vAns & "1:" & vAns _
& Cells(Rows.Count, vAns).End(xlUp).Row)

'Make sure lists contain more than 1 item
If Not IsArray(vRngA) Or Not IsArray(vRngB) Then _
Matches = -1: Exit Function

'Column to receive the results
vAns = Application.InputBox(sMsg _
& "where the new list is to go" & vbLf _
& "(Leave blank or click 'Cancel' to use column " _
& UCase$(sRngOut) & ")", Type:=2)
If Not vAns Or vAns = "" Then sRngOut = sRngOut _
Else sRngOut = vAns

'Debug.Print Now()
Dim dRngB As New Collection
On Error Resume Next
For j = LBound(vRngB) To UBound(vRngB)
dRngB.Add Key:=CStr(vRngB(j, 1)), Item:=CStr(vRngB(j, 1))
Next 'j
Err.Clear: On Error GoTo ErrExit

If AllowDupes Then '//fastest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
If dRngB.Item(CStr(vRngA(i, 1))) <> "" Then _
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1
skipit:
Next 'i

Else '//slowest
On Error GoTo MatchFound
For i = LBound(vRngA) To UBound(vRngA)
dRngB.Add Key:=CStr(vRngA(i, 1)), Item:=CStr(vRngA(i, 1))
Next 'i
End If 'AllowDupes
Err.Clear: On Error GoTo ErrExit

j = 0: ReDim vRngOut(UBound(vRngA) - lMatchesFound, 0)
For i = LBound(vRngA) To UBound(vRngA)
If Not vRngA(i, 1) = "" Then _
vRngOut(j, 0) = vRngA(i, 1): j = j + 1
Next 'i

Range(sRngOut & ":" & sRngOut).ClearContents
With Range(sRngOut & "1").Resize(UBound(vRngOut), 1)
.NumberFormat = "0000000000000"
.Value = vRngOut
.EntireColumn.AutoFit
End With
'Debug.Print Now()

ErrExit:
Matches = lMatchesFound: StripDupes = (Err = 0)
Exit Function

MatchFound:
If AllowDupes Then Resume skipit
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1: Resume Next

End Function 'StripDupes()
 
J

Jim Cone

Garry and Ron,
I was going to put my 2cents worth in here when appropriate, but discovered when testing the Dupes
code yesterday that MS created a problem in XL2010 with SpecialCells.
It causes a large delay in processing (sometimes minutes) while SpecialCells attempts to return an
answer. I discovered on the "Excel for Developers" website that is an admitted issue without a fix.
While trying to come up with a workaround for Special Cells, I discovered other unrelated code
problems.

Anyway, still working on the above and am undecided whether I should spend my time on something
worthwhile (maybe bowling).<g>
While I taking a breather, thought I would pass along a couple of items to consider when using
collections...
---
Dim dRngB As New Collection

is not as efficient as...

Dim dRngB As Collection
Set dRngB = New Collection

Apparently, there are some repetitive internal checks the first construct causes.
---
Also, you should find code is faster when adding to the collection, if you fill the Item with
vbNullstring.
The collection is just being used to dump duplicates and you can iterate the Keys just as easy as
the Items.
'---
Jim Cone






"GS" <[email protected]>
wrote in message
 
G

GS

After serious thinking Jim Cone wrote :
Garry and Ron,
I was going to put my 2cents worth in here when appropriate, but discovered
when testing the Dupes code yesterday that MS created a problem in XL2010
with SpecialCells.
It causes a large delay in processing (sometimes minutes) while SpecialCells
attempts to return an answer. I discovered on the "Excel for Developers"
website that is an admitted issue without a fix.
While trying to come up with a workaround for Special Cells, I discovered
other unrelated code problems.
Click to expand...

Not sure why this would be an issue since my code doesn't use
SpecialCells. What is the offending code?
Anyway, still working on the above and am undecided whether I should spend my
time on something worthwhile (maybe bowling).<g>
While I taking a breather, thought I would pass along a couple of items to
consider when using collections...
---
Dim dRngB As New Collection

is not as efficient as...

Dim dRngB As Collection
Set dRngB = New Collection

Apparently, there are some repetitive internal checks the first construct
causes.
Click to expand...

I'm not aware of this but will look into it. I'm just doing what I've
seen done in VB6. Collection is a built-in object class and so we
should be able to do it either way because all we're doing is creating
an instance of an existing object <AFAIK>.

I can see where this might be true for an external object like the
Scripting.Dictionary because VBA needs to verify a ref to that object.
I could be totally wrong but don't think this happens when we
instantiate intrinsic objects (or custom objects defined in a cls).
---
Also, you should find code is faster when adding to the collection, if you
fill the Item with vbNullstring.
The collection is just being used to dump duplicates and you can iterate the
Keys just as easy as the Items.
Click to expand...

I assume you're saying to fill the Key with vbNullString since we need
the Item for the test? Or, are you suggesting we fill Item with a
vbNullString and use Key for the test? I'm not sure why we should
change it since both need to be populated.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Make VBA ComboBox_Change work in 3 sheets 1
Multiple Regex Patterns 1
Using Collection to also capture range adjacent 10
Identify Hidden Columns - New issue! 19
Can't get soap client to connect in Excel 2010 64 bit 0
Change event code Find .Activate does not activate Target.value 4
Excel Do...Loop 0
Attn Ron Rosenfeld 10

Top