Function to return each cell of a value

spacebouncer

Board Regular
Joined
Feb 7, 2014
Messages
109
Hi. I'm trying to write a function to return a range. The function should look through a column, and return only one cell that has each value. Or to put another way, it needs to return a range that includes every unique cell, and just one cell from any that have the same value.

My best idea at the moment is to sort, and if the cell is not equal to the one below, then add it to the range. This seems pretty inelegant, and it would be preferable not to sort. Anyone have any better ideas for doing this? Thanks
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Perhaps like this:-
Code:
Private [COLOR=Navy]Sub[/COLOR] CommandButton2_Click()
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Txt [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Dim[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object
    [COLOR=Navy]Set[/COLOR] Rng = Range("A1:A31")
    MsgBox uRng(Rng).Address
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]


Function uRng(Rng [COLOR=Navy]As[/COLOR] Range) [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Dn [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object
[COLOR=Navy]Dim[/COLOR] nRng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
      [COLOR=Navy]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
        Dic.Add Dn.Value, Nothing
            [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
                [COLOR=Navy]Set[/COLOR] nRng = Dn
            [COLOR=Navy]Else[/COLOR]
                [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, Dn)
           [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR]
    [COLOR=Navy]Set[/COLOR] uRng = nRng
[COLOR=Navy]End[/COLOR] Function
Regards Mick
 
Upvote 0
Here's a one-line subroutine that will return the unique values from a selected range in an empty range that you can specify by choice of the parameter in red.
Rich (BB code):
Sub UniqueValuesOnly()
'Select your data range, then run this macro
'Change offset column # in next line to place output where you want it
Selection.AdvancedFilter Action:=xlFilterCopy, copytorange:=Selection.Cells(1, 1).Offset(0, 3), unique:=True
End Sub
 
Upvote 0
Thanks both.

MickG that was great thanks, just what I was looking for. I had to change a few details, and unfortunately I can't find much to read up on this, but I think I've got it. My code is below for your interest.

Code:
Function OneOfEach(Rng As Range) As Range
Dim cell As Range, nRng As Range
Dim Dict As Dictionary
Set Dict = New Dictionary
Dict.CompareMode = TextCompare
    
    For Each cell In Rng
        If Not Dict.exists(cell.Value) Then
            Dict.Add cell.Value, Nothing
            If OneOfEach Is Nothing Then
                Set OneOfEach = cell
            Else
                Set OneOfEach = Union(OneOfEach, cell)
            End If
        End If
    Next cell
    
Dict.RemoveAll
Set Dict = Nothing

End Function

Quick question if you don't mind, I'm very new to programming. Some example code included emptying the dictionary object, and then setting to nothing. Is this necessary? Is the dictionary object lost after the function has returned anyway? Thanks!
 
Upvote 0
I think it tends to be a personal preference when writing your code, I tend not to do it because, I usually want to keep the Dic Object in scope, as long as possible, , Except where I want to use the same dictionary object again, within the same code, then I just use "Dic.RemoveAll , but if you Google "Setting Objects to Nothing", you will get lots of information about it, from people much more knowledgeable that me.
 
Upvote 0

Forum statistics

Threads
1,226,616
Messages
6,192,040
Members
453,691
Latest member
CT30

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