List unique values from multiple sheets

[Steve]

Hi all. I have a workbook with 3 sheets. In Column C in Sheet1 and
Sheet2, there is a huge list of account numbers, many of which are
duplicates. Conceptually, I am trying to look at Sheet1 Column C and
Sheet2 Column C, merge the two lists together into one large list, and
then write out all the UNIQUE values from the combined list on Sheet3
Column A. Possible? Thanks in advance for your help!

 

[Bernard Liengme]

Chip at www.cpearson.com has lots of stuff on duplicates
best wishes

 

[jasontferrell]

Try this:

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

 

[Chip Pearson]

Try code like the following:

'''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
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)

 

[RB Smissaert]

If speed is important then go for a routine like this:

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