VBA: Create unique list from range of data

B

BIGTONE559

Active Member
Joined
Apr 20, 2011
Messages
336
I'm looking for an alternative method for creating a unique list from a range. I'm currently using advancefilter with the copyto range method. I would like to be able to go through my range (B10:B45) and copy unique items to a list beginning at Range(A30).

Thanks,
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
Try this on a copy of your data
Code: 
Sub UniqueList()
Dim uniqueArray() As Variant
Dim count As Integer
Dim notUnique As Boolean

ReDim uniqueArray(0) As Variant
uniqueArray(0) = Range("A1")
count = 0

Dim cl As Range
For Each cl In Range("B10:B45")
    notUnique = False
    For i = LBound(uniqueArray) To UBound(uniqueArray)
        If (cl.Value = uniqueArray(i)) Then
            notUnique = True
            Exit For
        End If
    Next i
    
    If notUnique = False Then
        count = count + 1
        ReDim Preserve uniqueArray(count) As Variant
        uniqueArray(UBound(uniqueArray)) = cl.Value
    End If
Next cl

    For i = LBound(uniqueArray) To UBound(uniqueArray)
        Range("B30").Offset(i, 0) = uniqueArray(i)
    Next i
End Sub
 
Upvote 0
this is a different way of doing it. should be much faster (not important for a handful of cells, but if you ever need to do something similar in the future)

you could use it something like

Code: 
sub print_unique
dim v
v=getuniquearray(range("b10:b45"))
if isarray(v) then
   range("a30").resize(ubound(v))=v
end if
end sub

Code: 
Public Function getUniqueArray(inputRange As Range, _
                                Optional skipBlanks As Boolean = True, _
                                Optional matchCase As Boolean = True, _
                                Optional prepPrint As Boolean = True _
                                ) As Variant
               
Dim vDic As Object
Dim tArea As Range
Dim tArr As Variant, tVal As Variant, tmp As Variant
Dim noBlanks As Boolean
Dim cnt As Long
                      
On Error GoTo exitFunc:
If inputRange Is Nothing Then GoTo exitFunc

With inputRange
    If .Cells.Count < 2 Then
        ReDim tArr(1 To 1, 1 To 1)
        tArr(1, 1) = .Value2
        getUniqueArray = tArr
        GoTo exitFunc
    End If

    Set vDic = CreateObject("scripting.dictionary")
    If Not matchCase Then vDic.compareMode = vbTextCompare
    
    noBlanks = True
    
    For Each tArea In .Areas
        tArr = tArea.Value2
        For Each tVal In tArr
            If tVal <> vbNullString Then
                vDic.Item(tVal) = Empty
            ElseIf noBlanks Then
                noBlanks = False
            End If
        Next
    Next
End With

If Not skipBlanks Then If Not noBlanks Then vDic.Item(vbNullString) = Empty

'this is done just in the case of large data sets where the limits of
'transpose may be encountered
If prepPrint Then
    ReDim tmp(1 To vDic.Count, 1 To 1)
    For Each tVal In vDic.Keys
        cnt = cnt + 1
        tmp(cnt, 1) = tVal
    Next
    getUniqueArray = tmp
Else
    getUniqueArray = vDic.Keys
End If

exitFunc:
Set vDic = Nothing
End Function
 
Upvote 0
pboltonchina said:
Try this on a copy of your data
Code: 
Sub UniqueList()
Dim uniqueArray() As Variant
Dim count As Integer
Dim notUnique As Boolean

ReDim uniqueArray(0) As Variant
uniqueArray(0) = Range("A1")
count = 0

Dim cl As Range
For Each cl In Range("B10:B45")
    notUnique = False
    For i = LBound(uniqueArray) To UBound(uniqueArray)
        If (cl.Value = uniqueArray(i)) Then
            notUnique = True
            Exit For
        End If
    Next i
    
    If notUnique = False Then
        count = count + 1
        ReDim Preserve uniqueArray(count) As Variant
        uniqueArray(UBound(uniqueArray)) = cl.Value
    End If
Next cl

    For i = LBound(uniqueArray) To UBound(uniqueArray)
        Range("B30").Offset(i, 0) = uniqueArray(i)
    Next i
End Sub
Click to expand...

Thanks for the reply pboltonchina! i noticed in the code it was Range(B30) and i changed it to Range(A30). Worked perfectly.

Chirp I tried your code as well and it worked perfectly! i appreciate both of your responses.

Both of your code works far faster than i could've ever imagined. my code took like 3 seconds to run (which is like 3 minutes to end users!) Thanks!!!

i'll use both!
 
Upvote 0
@Chirp--really like the way your code works. If I want to change the sheet that either the getuniquearray(range... refers to, and the sheet that the range outputs to (in your example it outputs the data to a30), how would I do that? Essentially, I need this to be able to pull duplicative data from one sheet and copy it uniquely to another sheet.


chirp said:
this is a different way of doing it. should be much faster (not important for a handful of cells, but if you ever need to do something similar in the future)

you could use it something like

Code: 
sub print_unique
dim v
v=getuniquearray(range("b10:b45"))
if isarray(v) then
   range("a30").resize(ubound(v))=v
end if
end sub

Code: 
Public Function getUniqueArray(inputRange As Range, _
                                Optional skipBlanks As Boolean = True, _
                                Optional matchCase As Boolean = True, _
                                Optional prepPrint As Boolean = True _
                                ) As Variant
               
Dim vDic As Object
Dim tArea As Range
Dim tArr As Variant, tVal As Variant, tmp As Variant
Dim noBlanks As Boolean
Dim cnt As Long
                      
On Error GoTo exitFunc:
If inputRange Is Nothing Then GoTo exitFunc

With inputRange
    If .Cells.Count < 2 Then
        ReDim tArr(1 To 1, 1 To 1)
        tArr(1, 1) = .Value2
        getUniqueArray = tArr
        GoTo exitFunc
    End If

    Set vDic = CreateObject("scripting.dictionary")
    If Not matchCase Then vDic.compareMode = vbTextCompare
    
    noBlanks = True
    
    For Each tArea In .Areas
        tArr = tArea.Value2
        For Each tVal In tArr
            If tVal <> vbNullString Then
                vDic.Item(tVal) = Empty
            ElseIf noBlanks Then
                noBlanks = False
            End If
        Next
    Next
End With

If Not skipBlanks Then If Not noBlanks Then vDic.Item(vbNullString) = Empty

'this is done just in the case of large data sets where the limits of
'transpose may be encountered
If prepPrint Then
    ReDim tmp(1 To vDic.Count, 1 To 1)
    For Each tVal In vDic.Keys
        cnt = cnt + 1
        tmp(cnt, 1) = tVal
    Next
    getUniqueArray = tmp
Else
    getUniqueArray = vDic.Keys
End If

exitFunc:
Set vDic = Nothing
End Function
Click to expand...
 
Upvote 0
My apologies on pulling up such an old thread, but I have been trying to tweak this code and I am now having some issues.

Essentially I will be running the code from Sheet1, but the list I need to pull from is in Sheet3 lets say range b2:b1000

And I need the unique items to populate in Sheet6 starting with A1

Is anyone able to assist with this?

pboltonchina said:
Try this on a copy of your data
Code: 
Sub UniqueList()
Dim uniqueArray() As Variant
Dim count As Integer
Dim notUnique As Boolean

ReDim uniqueArray(0) As Variant
uniqueArray(0) = Range("A1")
count = 0

Dim cl As Range
For Each cl In Range("B10:B45")
    notUnique = False
    For i = LBound(uniqueArray) To UBound(uniqueArray)
        If (cl.Value = uniqueArray(i)) Then
            notUnique = True
            Exit For
        End If
    Next i
    
    If notUnique = False Then
        count = count + 1
        ReDim Preserve uniqueArray(count) As Variant
        uniqueArray(UBound(uniqueArray)) = cl.Value
    End If
Next cl

    For i = LBound(uniqueArray) To UBound(uniqueArray)
        Range("B30").Offset(i, 0) = uniqueArray(i)
    Next i
End Sub
Click to expand...
 
Upvote 0
Hello mate, I've just stumbled across this thread today and found that the option provided by chirp is very fast (sub 1sec on 300k rows) and works perfectly every time so recommend using that.

Note when copying the code that in the sub, the .Resize() bit is necessary to get the full output (otherwise you just get the first entry).

Your code in that instance would be:

sub print_unique
dim v
v=getuniquearray(Worksheets("Sheet1").Range("B2:B1000"))
if isarray(v) then
Worksheets("Sheet6").Range("A1").resize(ubound(v))=v
end if
end sub

If you have more than one workbook open, you may want to fully qualify the references i.e.:
- ThisWorkbook.Worksheets("Sheet1").Range("B2:B1000")
- ThisWorkbook.Worksheets("Sheet6").Range("A1").resize(ubound(v))
 
Last edited:
Upvote 0
@Chirp, I have found I'm unable to access entries in the array i.e. once unique array has been created, I'd like to loop through it to identify which entries are new compared to a different list.

I don't seem to be able to use v(i) for the ith element and seeing it passes it as a range, I also tried v.Cells(1,1).Value and things like that and always get errors:
- 'Subscript out of range' for trying v(i) and tried in the immediate window various values of i
- Object requried when trying to interact with it like a range

Any thoughts?
 
Upvote 0
chirp said:
this is a different way of doing it. should be much faster (not important for a handful of cells, but if you ever need to do something similar in the future)

you could use it something like

Code: 
sub print_unique
dim v
v=getuniquearray(range("b10:b45"))
if isarray(v) then
   range("a30").resize(ubound(v))=v
end if
end sub

Code: 
Public Function getUniqueArray(inputRange As Range, _
                                Optional skipBlanks As Boolean = True, _
                                Optional matchCase As Boolean = True, _
                                Optional prepPrint As Boolean = True _
                                ) As Variant
               
Dim vDic As Object
Dim tArea As Range
Dim tArr As Variant, tVal As Variant, tmp As Variant
Dim noBlanks As Boolean
Dim cnt As Long
                      
On Error GoTo exitFunc:
If inputRange Is Nothing Then GoTo exitFunc

With inputRange
    If .Cells.Count < 2 Then
        ReDim tArr(1 To 1, 1 To 1)
        tArr(1, 1) = .Value2
        getUniqueArray = tArr
        GoTo exitFunc
    End If

    Set vDic = CreateObject("scripting.dictionary")
    If Not matchCase Then vDic.compareMode = vbTextCompare
    
    noBlanks = True
    
    For Each tArea In .Areas
        tArr = tArea.Value2
        For Each tVal In tArr
            If tVal <> vbNullString Then
                vDic.Item(tVal) = Empty
            ElseIf noBlanks Then
                noBlanks = False
            End If
        Next
    Next
End With

If Not skipBlanks Then If Not noBlanks Then vDic.Item(vbNullString) = Empty

'this is done just in the case of large data sets where the limits of
'transpose may be encountered
If prepPrint Then
    ReDim tmp(1 To vDic.Count, 1 To 1)
    For Each tVal In vDic.Keys
        cnt = cnt + 1
        tmp(cnt, 1) = tVal
    Next
    getUniqueArray = tmp
Else
    getUniqueArray = vDic.Keys
End If

exitFunc:
Set vDic = Nothing
End Function
Click to expand...
Thank you so so much, after hours of search, I finally found this (very easy) way to list all my tables with a unique value without having to copy-paste-remove duplicates...and not even a blank cell! Cheers
 
Upvote 0
BIGTONE559 said:
I'm looking for an alternative method for creating a unique list from a range. I'm currently using advancefilter with the copyto range method. I would like to be able to go through my range (B10:B45) and copy unique items to a list beginning at Range(A30).

Thanks,
Click to expand...
Old thread, but a much cleaner answer in case someone is still looking for answers.

ActiveSheet.Range("B10:B45").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveSheet.Range("A30"), Unique:=True
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Creating A List of Unique Values
Replies
5
Views
45
mumps
mumps
B
  • Solved
Creating Unique list from Customer Order Amount, Customer Name and Order Identifier using the Unique function
2
Replies
11
Views
368
etaf
etaf
A
  • Question Question
Creating A Validation List From Unique Values in A Column (Filtered and unfiltered)
Replies
3
Views
537
RoryA
RoryA
G
  • Question Question
Vstack a variable range of 1D vertical arrays
Replies
3
Views
433
dreid1011
dreid1011
FatalLordes
  • Question Question
Excel Online and Reports from Multiple Tabs
Replies
2
Views
400
FatalLordes
FatalLordes

Forum statistics

Threads
1,224,766
Messages
6,180,846
Members
453,001
Latest member
coulombevin

Share this page

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