View Single Post
  #58   Report Post  
Posted to microsoft.public.excel.programming
GS[_2_] GS[_2_] is offline
external usenet poster
 
Posts: 3,514
Default Delete matching cells

We can shave off even more time if we eliminate the checks when adding
items to the dictionary because the dictionary won't allow dupes...

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&, lRows1&, lRows2&, lMatchesFound& 'as long
Dim vRngA, vRngB, vRngOut() 'as variant
Dim dRngB As New Dictionary

On Error GoTo ErrExit

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

On Error Resume Next
For j = LBound(vRngB) To UBound(vRngB)
dRngB.Add Key:=vRngB(j, 1), Item:=vRngB(j, 1)
Next 'j
On Error GoTo 0

If AllowDupes Then '//fastest
For i = LBound(vRngA) To UBound(vRngA)
If dRngB.Exists(Key:=vRngA(i, 1)) Then _
vRngA(i, 1) = "": lMatchesFound = lMatchesFound + 1
Next 'i

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

Else '//slowest
Dim dRngA As New Dictionary
On Error Resume Next
For i = LBound(vRngA) To UBound(vRngA)
If Not dRngB.Exists(vRngA(i, 1)) Then _
dRngA.Add Key:=vRngA(i, 1), Item:=vRngA(i, 1)
Next 'i
On Error GoTo 0

Dim v As Variant
j = 0: ReDim vRngOut(dRngA.Count, 0)
For Each v In dRngA
vRngOut(j, 0) = dRngA(v): j = j + 1
Next 'v
End If 'AllowDupes

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

ErrExit:
StripDupes = (Err = 0)
End Function 'StripDupes()

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc