Delete matching cells
On Sat, 14 Jan 2012 22:08:27 -0800 (PST), gary wrote:
I have deleted the duplicates in col A and in Col B.
When I re-ran your macro, I still got the Run-time Error '13'
Type Mismatch in
rColA = WorksheetFunction.Transpose(vColA)
The presence or absence of duplicates is irrelevant to this error. I cannot be sure, but in older versions of Excel (prior to 2003) there were limits in the size of an array that you could use worksheetfunction.transpose. I thought it had been removed, but perhaps not.
How long did the macro run before hitting that error? Because that's at the end and the next step would be quick.
Try this variation where transposing is not required:
==================================
Option Explicit
Sub PruneColA()
'Requires setting reference (tools/references) to
' Microsoft Scripting Runtime
Dim ws As Worksheet
Dim rColA As Range, rColB As Range
Dim vColA As Variant, vColB As Variant
Dim dColA As Dictionary, dColB As Dictionary
Dim i As Long
Dim d As Variant
Set dColA = New Dictionary
Set dColB = New Dictionary
Set ws = Worksheets("Sheet2")
With ws
Set rColA = Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
Set rColB = Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp))
End With
vColB = rColB
vColA = rColA
For i = LBound(vColB, 1) + 1 To UBound(vColB, 1)
With dColB
If Not .Exists(Key:=vColB(i, 1)) Then .Add Key:=vColB(i, 1), Item:=vColB(i, 1)
End With
Next i
For i = LBound(vColA, 1) + 1 To UBound(vColA, 1)
If Not dColB.Exists(Key:=vColA(i, 1)) Then
With dColA
If Not .Exists(Key:=vColA(i, 1)) Then .Add Key:=vColA(i, 1), Item:=vColA(i, 1)
End With
End If
Next i
ReDim vColA(1 To dColA.Count, 1 To 1)
i = 0
For Each d In dColA
i = i + 1
vColA(i, 1) = dColA(d)
Next d
rColA.Offset(rowoffset:=1).ClearContents
Set rColA = rColA.Resize(rowsize:=dColA.Count).Offset(rowoffse t:=1)
rColA = vColA
End Sub
===================================
|