create list of unique values

blackbox

Board Regular
Joined
Apr 2, 2006
Messages
122
I know the Advanced filter does this but I couldn't get it to work in vba, so I tried the following and couldn't get it to work either :)
In column A I have values starting at row 4, ranging up to row 1004.

in coulumn Q (starting at row 3) I'd like a list of unique entries from column A

I know this line is my problem
Code:
If Range("A" & I) <> Range("Q4:Q30") Then
but i'm not sure how to compare against all values in a range

Code:
Sub FilterSymbol()
Dim I As Integer
Dim X As Integer
X = Range("O2")
I = 4

Do
If Range("A" & I) <> Range("Q4:Q30") Then
Range("Q" & I) = Range("A" & I)
I = I + 1
Else: I = I + 1
End If
Loop Until I >= X
 
End Sub
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
AdvancedFilter should work as well

Code:
Dim rMain  As Range
    Dim rTo    As Range
    With Sheet1
        Set rTo = .Cells(3, 17)
        Set rmain = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))

        .Columns(17).Clear
        rmain.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rTo, Unique:=True
    End With
 
Upvote 0
Andrew,

in the example code from your link, how do I create the list in the worksheet instead of creating a userform?
Code:
'   Add the sorted, non-duplicated items to a ListBox
    For Each Item In NoDupes
        UserForm1.ListBox1.AddItem Item
    Next Item

'   Show the UserForm
    'UserForm1.Show
how do I designate a range?



Code:
Option Explicit
'   This example is based on a tip by J.G. Hussey,
'   published in "Visual Basic Programmer's Journal"

Sub RemoveDuplicates()
    Dim AllCells As Range, Cell As Range
    Dim NoDupes As New Collection
    Dim i As Integer, j As Integer
    Dim Swap1, Swap2, Item
    
'   The items are in A1:A105
    Set AllCells = Range("A4:A1003")
    
'   The next statement ignores the error caused
'   by attempting to add a duplicate key to the collection.
'   The duplicate is not added - which is just what we want!
    On Error Resume Next
    For Each Cell In AllCells
        NoDupes.Add Cell.Value, CStr(Cell.Value)
'       Note: the 2nd argument (key) for the Add method must be a string
    Next Cell

'   Resume normal error handling
    On Error GoTo 0

'   Sort the collection (optional)
    For i = 1 To NoDupes.Count - 1
        For j = i + 1 To NoDupes.Count
            If NoDupes(i) > NoDupes(j) Then
                Swap1 = NoDupes(i)
                Swap2 = NoDupes(j)
                NoDupes.Add Swap1, before:=j
                NoDupes.Add Swap2, before:=i
                NoDupes.Remove i + 1
                NoDupes.Remove j + 1
            End If
        Next j
    Next i
    
'   Add the sorted, non-duplicated items to a ListBox
    For Each Item In NoDupes
        UserForm1.ListBox1.AddItem Item
    Next Item

'   Show the UserForm
    UserForm1.Show
End Sub
 
Upvote 0
royUk,

i tried you code, it copies the first value from column A to cell Q3 but stops there
Code:
Sub NewFilter()
Dim rMain  As Range
    Dim rTo    As Range
    With Sheet1
        Set rTo = .Cells(3, 17)
        Set rMain = .Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp))

        .Columns(17).Clear
        rMain.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rTo, Unique:=True
    End With
End Sub


tried adding the following loop to it but it displays the value of A3 in Q3 thenclears it and displays A4 in Q4, and so on

Code:
Sub New_filter()
Dim rMain  As Range
    Dim i As Integer
    Dim rTo    As Range
    Dim X As Integer
    
     X = Range("O2")
     i = 4
    Do
    With Sheet1
        Set rTo = .Cells(3, 17)
        Set rMain = .Range(.Cells(i, 1), .Cells(.Rows.Count, 1).End(xlUp))

        '.Columns(17).Clear
        rMain.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rTo, Unique:=True
    End With
    i = i + 1
    Loop Until i > X
End Sub
 
Upvote 0
Unique with Dictionary object and an array
try
Code:
Sub test()
Dim a, e, x
a = Range("a4:a1003").Value
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For Each e In a
          If Not .exists(e) Then .add e, Nothing
     Next
     x = .keys
End With
SortA x, 0, UBound(x)
UserForm1.ListBox1.List = x
End Sub

Private Sub SortA(ary, LB, UB)
Dim i As Long, ii As Long, M As Variant, temp As Variant
i = UB : ii = LB
M = ary(Int((LB + UB)/2))
Do While ii <= i
     Do While ary(ii) < M
          ii = ii + 1
     Loop
     Do While ary(i) > M
          i = i - 1
     Loop
     If ii <= i Then
          temp = ary(ii) : ary(ii) = ary(i) : ary(i) = temp
          i = i - 1 : ii = ii + 1
     End If
Loop
If LB < i Then SortA ary, LB, i
If ii < UB Then SortA ary, ii, UB
End Sub
 
Upvote 0
hi Jindon,

got Compile error: Syntax error on


Code:
Dim i As Long,. ii As Long, M As Variant, temp As Variant

of Sub SortA
 
Upvote 0
removed period

now get Run-time error 13: Type mismatch on

Code:
 Do While ary(i) > M

also Sub SortA
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top