"Steve" <steve_a...@yahoo.com> wrote in message
news:04893666-c564-419f...@w9g2000yqa.googlegroups.com...
Public Sub CreateUniqueList()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim shtOut As Worksheet
Dim lRow As Long, lCount As Long
Set sht1 = Sheets("Sheet1")
Set sht2 = Sheets("Sheet2")
Set shtOut = Sheets.Add
sht1.Range(sht1.Cells(1, 3), sht1.Cells(1, 3).End(xlDown)).Copy
shtOut.Range("A1").PasteSpecial
sht2.Range(sht2.Cells(1, 3), sht2.Cells(1, 3).End(xlDown)).Copy
shtOut.Range("A1").End(xlDown).Offset(1, 0).PasteSpecial
shtOut.Range(shtOut.Cells(1, 1), shtOut.Cells(1, 1).End
(xlDown)).Sort _
Key1:=shtOut.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortTextAsNumbers
lRow = 2
For lCount = 1 To shtOut.UsedRange.Rows.Count
If shtOut.Cells(lRow, 1).Value = shtOut.Cells(lRow - 1,
1).Value Then
shtOut.Cells(lRow, 1).EntireRow.Delete
Else
lRow = lRow + 1
End If
Next lCount
Set shtOut = Nothing
Set sht2 = Nothing
Set sht1 = Nothing
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
Sub MergeDistinct()
Dim R As Range
Dim LastCell As Range
Dim WS As Worksheet
Dim N As Long
Dim M As Long
Dim R3A As Range
Set R3A = Worksheets("Sheet3").Range("A1") '<<< OUTPUT STARTS HERE
' Sheet1
Set WS = Worksheets("Sheet1")
With WS
M = 1
Set LastCell = .Cells(.Rows.Count, "C").End(xlUp)
For Each R In .Range(.Range("C1"), LastCell)
N = Application.CountIf(R3A.Resize(M, 1), R.Text)
If N = 0 Then
R3A(M, 1) = R.Text
M = M + 1
End If
Next R
End With
' Sheet2
Set WS = Worksheets("Sheet2")
With WS
Set LastCell = .Cells(.Rows.Count, "C").End(xlUp)
For Each R In .Range(.Range("C1"), LastCell)
N = Application.CountIf(R3A.Resize(M, 1), R.Text)
If N = 0 Then
R3A(M, 1) = R.Text
M = M + 1
End If
Next R
End With
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)
Sub GetUniqueItems()
Dim i As Long
Dim LR As Long
Dim arr
Dim arrUnique
Dim coll As Collection
Set coll = New Collection
'pick up the numbers from sheet 1 and add to the collection
With Sheets(1)
LR = .Cells(.Rows.Count, 3).End(xlUp).Row
arr = .Range(.Cells(3), .Cells(LR, 3))
On Error Resume Next
For i = 1 To UBound(arr)
coll.Add arr(i, 1), CStr(arr(i, 1))
Next i
On Error GoTo 0
End With
'pick up the numbers from sheet 2 and add to the collection
With Sheets(2)
LR = .Cells(.Rows.Count, 3).End(xlUp).Row
arr = .Range(.Cells(3), .Cells(LR, 3))
On Error Resume Next
For i = 1 To UBound(arr)
coll.Add arr(i, 1), CStr(arr(i, 1))
Next i
On Error GoTo 0
End With
'transfer the collection to an array
ReDim arrUnique(1 To coll.Count, 1 To 1)
For i = 1 To coll.Count
arrUnique(i, 1) = coll.Item(i)
Next i
'dump the array with unique numbers in sheet 3
With Sheets(3)
.Range(.Cells(1), .Cells(UBound(arrUnique), 1)) = arrUnique
End With
End Sub
If this is not fast enough then you could use the cCollection class in
dhRichClient3.dll, which can be downloaded here:
www.datenhaus.de/Downloads/dhRichClient3.zip
RBS
"Steve" <steve_a...@yahoo.com> wrote in message
news:04893666-c564-419f...@w9g2000yqa.googlegroups.com...