Extracting unique numbers

[jeffmoseler]

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!

 

[agihcam]

give exact range / page where your data in.

 

[jeffmoseler]

The data is in Sheet2, BC2 to BC10
The results should be in Sheet3, A3 to A11

I hope this helps!

 

[agihcam]

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]

Try this:

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]

or try this;
with a little modifications from Jindon's code for dictionary object.Thanks to Jindon once again.

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]

Works like a charm! You guys are awesome!

 

[Yogi Anand]

Hi Jeff Moseler:

Following is a non-macro approach ...

Book1
	A	B	C	D
1
2
3	Sample data:		Two Step Operation -- A non-macro approach
4	3
5	4		Step1
6	9		I used AdvancedFilter to extract Unique records from range Sheet2!B2:B10
7	14
8	31		Step2
9	35		I sorted the data in cells A3:A10 in Ascending Order
10	44
11
Sheet3

 

[jeffmoseler]

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

 

[jeffmoseler]

Bump