# Extracting unique numbers

#### jeffmoseler

##### Well-known Member
Hello all. Thanks for any help!

I need to extract a list of unique records and list them in order from lowest to highest. I can't use a filter because it needs to be done on a different page than the data is in.

Sample data:
35
3
14
4

31
44
9
35

3
4
9
14
31
35
44

I looked in the archives but I couldn't find anything. Any help would be apprectiated!

### Excel Facts

If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

#### agihcam

##### Well-known Member
give exact range / page where your data in.

#### jeffmoseler

##### Well-known Member
The data is in Sheet2, BC2 to BC10
The results should be in Sheet3, A3 to A11

I hope this helps!

#### agihcam

##### Well-known Member
how about advanced filter ( unique records only ) to certain column where your original data then cut and paste into sheet3? or do you want it done automatically?

#### SydneyGeek

##### MrExcel MVP

Try this:

Code:
``````Sub Macro1()
Dim c As Range
Dim Rw As Long, RwLast As Long

Range("BC2:BC10").Copy
Sheets("Sheet3").Activate
Range("A1").PasteSpecial Paste:=xlPasteValues
Range("A1:A10").Select
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
RwLast = Range("A65536").End(xlUp).Row
For Rw = RwLast To 2 Step -1
'to delete row
If Cells(Rw, 1).Value = Cells(Rw - 1, 1).Value Then Cells(Rw, 1).EntireRow.Delete
'to delete cell
If Cells(Rw, 1).Value = Cells(Rw - 1, 1).Value Then Cells(Rw, 1).Delete shift:=xlShiftUp
Next Rw
End Sub``````
The code goes into a new module (Alt+F11, Insert>Module, Paste, then Alt+Q to return to Excel).
To run the code, press Alt+F8 and double-click the macro name.

Denis

#### agihcam

##### Well-known Member
or try this;
with a little modifications from Jindon's code for dictionary object.Thanks to Jindon once again.
Code:
``````Sub test()
Dim i As Long
Dim dic As Object, w()
Set dic = CreateObject("scripting.dictionary")
If IsEmpty(Sheets("Sheet3").Range("a2")) Then
Sheets("Sheet3").Range("a2").Value = "temp"
End If
With Sheets("Sheet2")
i = .Range("bc" & Rows.Count).End(xlUp).Row
For Each r In .Range("bc2:bc" & i)
If Not IsEmpty(r) Then
If Not dic.exists(r.Value) Then
ReDim w(0)
w(0) = r.Value
Sheets("Sheet3").Range("a" & Rows.Count).End(xlUp).Offset(1) = w(0)
End If
End If
Next
End With
With Sheets("Sheet3")
If .Range("a2").Value = "temp" Then .Range("a2").ClearContents
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub``````

#### jeffmoseler

##### Well-known Member

Works like a charm! You guys are awesome!

#### Yogi Anand

##### MrExcel MVP
Hi Jeff Moseler:

Following is a non-macro approach ...
Book1
ABCD
1
2
3Sample data:Two Step Operation -- A non-macro approach
43
54Step1
69I used AdvancedFilter to extract Unique records from range Sheet2!B2:B10
714
831Step2
935I sorted the data in cells A3:A10 in Ascending Order
1044
11
Sheet3

#### jeffmoseler

##### Well-known Member
OK, I'm not as smart as I thought. I need the original code to work for 8 consecutive columns, starting with BC and ending with BJ. Each copying over the unique numbers for that column. I thought I could break down the original code and make it work for the other columns, but alas, I know so little about visual basic that it fell apart and I don't know why. So at the obvious expense of truely embarrassing my self, I copied in what I tried to do. Can anyone help me make it work for the next columns?

Sub test()
' Gun 1
Dim i As Long
Dim dic As Object, w()
Set dic = CreateObject("scripting.dictionary")
If IsEmpty(Sheets("Sheet3").Range("a2")) Then
Sheets("Sheet3").Range("a2").Value = "temp"
End If
With Sheets("Sheet2")
i = .Range("bc" & Rows.Count).End(xlUp).Row
For Each r In .Range("bc2:bc" & i)
If Not IsEmpty(r) Then
If Not dic.exists(r.Value) Then
ReDim w(0)
w(0) = r.Value
Sheets("Sheet3").Range("a" & Rows.Count).End(xlUp).Offset(1) = w(0)
End If
End If
Next
End With
With Sheets("Sheet3")
If .Range("a2").Value = "temp" Then .Range("a2").ClearContents
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
' Gun 2
Dim i As Long
Dim dic As Object, w()
Set dic = CreateObject("scripting.dictionary")
If IsEmpty(Sheets("Sheet3").Range("b2")) Then
Sheets("Sheet3").Range("b2").Value = "temp"
End If
With Sheets("Sheet2")
i = .Range("bd" & Rows.Count).End(xlUp).Row
For Each r In .Range("bd2:bd" & i)
If Not IsEmpty(r) Then
If Not dic.exists(r.Value) Then
ReDim w(0)
w(0) = r.Value
Sheets("Sheet3").Range("b" & Rows.Count).End(xlUp).Offset(1) = w(0)
End If
End If
Next
End With
With Sheets("Sheet3")
If .Range("b2").Value = "temp" Then .Range("b2").ClearContents
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

End Sub

Bump

Replies
3
Views
80
Replies
3
Views
43
Replies
8
Views
159
Replies
0
Views
26
Replies
5
Views
115