Extracting unique numbers

jeffmoseler

Well-known Member
Joined
Jul 16, 2004
Messages
539
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

Answer:
3
4
9
14
31
35
44

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

Some videos you may like

Excel Facts

Links? Where??
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.

jeffmoseler

Well-known Member
Joined
Jul 16, 2004
Messages
539
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
Joined
Jan 16, 2006
Messages
1,624
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
Joined
Aug 5, 2003
Messages
12,251

ADVERTISEMENT

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
    Selection.Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        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
Joined
Jan 16, 2006
Messages
1,624
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
                  dic.Add r.Value, w(0)
                    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
    .Range("A3:A11").Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub
 

jeffmoseler

Well-known Member
Joined
Jul 16, 2004
Messages
539

ADVERTISEMENT

Works like a charm! You guys are awesome!
 

Yogi Anand

MrExcel MVP
Joined
Mar 12, 2002
Messages
11,454
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
Joined
Jul 16, 2004
Messages
539
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
dic.Add r.Value, w(0)
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
.Range("A3:A11").Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
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
dic.Add r.Value, w(0)
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
.Range("b3:b11").Sort Key1:=.Range("b3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,112,211
Messages
5,541,845
Members
410,550
Latest member
ganeshsamant
Top