Create Unique List from Selected Cells

Well, it’s almost next year and you know what that means: New vendor files. I need to create a couple hundred labels for next year’s vendor files. I started by exporting all of the bills from all of the vendors for this year. Next, I’m going to count and sum the bills. Then I’m going to find the newest invoice date. With that, I should be able to weed out vendors we likely won’t pay next year and those whose invoices are so few that they go in the Misc. folder.

But I need to start with a list of all the vendors who had bills. I’m so sick of creating unique lists with formulas, that I finally just wrote a utility to do it.

Recently added to my Personal.xls

Sub GetUniqueList()

Dim rCell As Range
Dim colUnique As Collection
Dim sh As Worksheet
Dim i As Long

'only work on ranges
If TypeName(Selection) = "Range" Then

'create a new collection
Set colUnique = New Collection

'loop through all selected cells
'and add to collection
For Each rCell In Selection.Cells
On Error Resume Next
'if value exists, it won’t be added
colUnique.Add rCell.Value, CStr(rCell.Value)
On Error GoTo 0
Next rCell

'make a new sheet to put the unique list
Set sh = ActiveWorkbook.Worksheets.Add

'Write the unique list to the new sheet
For i = 1 To colUnique.Count
sh.Range("A1").Offset(i, 0).Value = colUnique(i)
Next i

'sort with no headers
sh.Range(sh.Range("A2"), sh.Range("A2").End(xlDown)) _
.Sort sh.Range("A2"), xlAscending, , , , , , xlNo

End If

End Sub

32 thoughts on “Create Unique List from Selected Cells

  1. I would typically just create a pivot table of the vendors to get this list. That would also give you the count and sum of the bills.

  2. What about reading the range into an array, and going from there? Might be faster if you’ve selected a lot of cells. Or, since you’re writing the unique list back to the worksheet, the AdvancedFilter Method?

  3. I use 2 buttons, CopyUnique, PasteUnique.
    The CopyUnique button is tied to a code which uses the Advanced Filters – copy to option

    This allows me to past the unique items wherever I require.

    Public Ctem()
    Public Ctemp()
    Public Cu
    Public Cont

    Sub Copy_Unique()
    Cu = 0
    Application.ScreenUpdating = False
    Range(Selection.Address()).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For Each cp In Selection.SpecialCells(xlCellTypeVisible)
    ReDim Preserve Ctemp(Cu)
    Ctemp(Cu) = cp.Value
    Cu = Cu + 1
    Next
    If ActiveSheet.FilterMode = True Then
    ActiveSheet.ShowAllData
    Else
    End If
    Application.ScreenUpdating = True
    End Sub

    Sub Paste_Unique()
    ReDim Preserve Ctemp(Cu)
    Application.ScreenUpdating = False
    For i = 0 To Cu
    ActiveCell.Value = Ctemp(i)
    ActiveCell.Offset(1, 0).Activate
    Next
    Application.ScreenUpdating = True
    End Sub

    An Alternate way....

    Sub CopyUniqueItems()
    If Selection.Columns.Count > 1 Or Selection.Rows.Count

  4. This is perfect, I just needed to create such a list! Like Paul I was thinking about a pivot, but this script gives me more ideas and perspectives for adding some extra features.

  5. I could be wrong but I’m sure I saw a ‘Remove Duplicates’ button in Excel 2007 that does this the other day? Or I could well have misunderstood what you are trying to do…

  6. Last time I had this type of problem I built something like this, a good excuse build a simple Class Module. Easy to use and no fuss. Good way to teach people how they work.

    Option Explicit

    Dim ListUniqueItem() As String
    Private Sub Class_Initialize()
    ReDim ListUniqueItem(0)
    End Sub

    Public Sub AddItem(ByVal UniqueItem As String)
    If CheckItem(UniqueItem) = False Then
    ReDim Preserve ListUniqueItem(UBound(ListUniqueItem) + 1)
    ListUniqueItem(UBound(ListUniqueItem)) = UniqueItem
    End If
    End Sub

    Public Function CheckItem(UniqueItem As String) As Long
    Dim counter As Long
    For counter = 1 To UBound(ListUniqueItem)
    If ListUniqueItem(counter) = UniqueItem Then
    CheckItem = counter
    Exit Function
    End If
    Next
    End Function

    Public Function UniqueItem(Index As Long) As String
    If Index

  7. I am killing this thread is there no way to delete these posts….

    Option Explicit

    Dim ListUniqueItem() As String
    Private Sub Class_Initialize()
    ReDim ListUniqueItem(0)
    End Sub

    Public Sub AddItem(ByVal UniqueItem As String)
    If CheckItem(UniqueItem) = False Then
    ReDim Preserve ListUniqueItem(UBound(ListUniqueItem) + 1)
    ListUniqueItem(UBound(ListUniqueItem)) = UniqueItem
    End If
    End Sub

    Public Function CheckItem(UniqueItem As String) As Long
    Dim counter As Long
    For counter = 1 To UBound(ListUniqueItem)
    If ListUniqueItem(counter) = UniqueItem Then
    CheckItem = counter
    Exit Function
    End If
    Next
    End Function

    Public Function UniqueItem(Index As Long) As String
    If Index

  8. What’s the difficulty with using Data…Filter…Advanced Filter with “Unique records only” checked and the “Copy to another location” option button selected?

  9. Jan, all: If you use a less-than sign in your code, WordPress thinks you’re starting an hmtl tag, which is why nothing shows up after that. You have to escape it by replacing the less-than signs with & #060; or & lt; without the spaces in there. Sorry, it’s a bug and I don’t know how to fix it.

  10. I would have liked to use an array, particularly for writing back to the worksheet. But I don’t know a good way to get uniques from an array. I could have looped through the collection and created an array, but if I’m already looping through the collection, I may as well just write to the cells. For 6,000 items that produced 200 uniques, it took only a second.

    If I use a pivot table, I have to copy and paste the results to a new sheet. Ultimately (for this application), I need a well formed list that I can mail merge into Word to create the labels. Also, the count wouldn’t work in a pt. If there are two line items on the bill, it shows up twice. I had to write a special function to count the unique invoice numbers per client.

    But the AdvancedFilter method might have been a better way.

  11. Dick: If you use a Dictionary rather than a Collection, you can then use the Keys property to get an array of keys.

    I assume there is a legitimate reason for not using a filter or a PT or some such. The most likely I guess would be the data are not in a table (a conclusion based on your using Selection.Cells). If so, the code below creates a table and then filters unique values to another location. And, for those inclined to focus on off-topic issues, yes, there are no safety checks. Add them yourself. {grin}

    Option Explicit

    Sub uniqueVals()
        Dim anArea As Range, aCol As Range, WS As Worksheet, SrcRng As Range
        Set SrcRng = Selection
        Set WS = SrcRng.Parent.Parent.Worksheets.Add
        WS.Cells(1, 1).Value = “Workspace”
        For Each anArea In SrcRng.Areas
            For Each aCol In anArea.Columns
                aCol.Copy
                WS.Cells(WS.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
                Next aCol
            Next anArea
        WS.UsedRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=WS.Range(“B1”), Unique:=True
        WS.Columns(1).Delete
        End Sub

  12. I am a bit surprised none of the 007 fans suggested the new Remove duplicates method.

    Assuming Data is on Sheet1 and Sheet2 is blank

    Sub UniqueItems()
    Selection.Copy Destination:= _
    Sheet2.Range(“A1?)
    EndRow = Sheet2.Cells.Find(“*”, After:=Range(“IV65536?), SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row
    Sheet2.Range(“A1:A” & EndRow).RemoveDuplicates Columns:=1, Header:=xlYes
    End Sub

  13. [i][quote]I would have liked to use an array, particularly for writing back to the worksheet. But I don’t know a good way to get uniques from an array[quote][i]
    One-dimensional arrays have extra facilities (split, join, filter), with which double elements can be filtered.

    Sub tst()
      sq = Application.WorksheetFunction.Transpose([A:A].SpecialCells(xlCellTypeConstants))
      For j = 1 To UBound(sq)
        If UBound(Filter(sq, sq(j))) > 0 Then sq(j) = “#”
      Next
      sq = Filter(sq, “#”, False)
      Sheets(1).[B1].Resize(UBound(sq)) = Application.WorksheetFunction.Transpose(sq)
    End Sub
  14. Sub tst()
      Dim sq As Variant
      Dim j As Long
     
      sq = Application.WorksheetFunction.Transpose([A:A].SpecialCells(xlCellTypeConstants))
      For j = 1 To UBound(sq)
        If UBound(Filter(sq, sq(j))) > 0 Then sq(j) = “#”
      Next
      sq = Filter(sq, “#”, False)
      Sheets(1).[B1].Resize(UBound(sq) + 1) = Application.WorksheetFunction.Transpose(sq)
    End Sub

    That’s nice Hans. I modded the code to add 1 to the Ubound. Filter returns a zero based array so we needed one more spot to get all of the values.

  15. It’s funny, I use a collection to extract uniquie items as well. I played around with reading the list to an array, then sorting the array, then removing the dups from the array before writing it back out to a range, but it took a lot of code and a lot of time. So I went with a collection.

    But instead of a routine, I actually created it as a class so that i could take anywhere I wanted. I also evaluate the number of columns in the selected range and if it’s more than 1, I read the whole row in, separating the data with a tab, and then, after I write it out again, I use text to columns to split out the data.

    My next plan is to wrap all this into a form to make it dynamic and really easy to use.

    Sub ExtractItems()

        Dim clsExtract As CUniqueItems
        Dim rngSel As Range, rngTar As Range
       
        Set clsExtract = New CUniqueItems
        Set rngSel = Selection
        Set rngTar = ThisWorkbook.Sheets(“Sheet2”).Range(“A1”)
       
        clsExtract.TheSelection = rngSel
        clsExtract.Target = rngTar
        clsExtract.ExtractUniques
       
    End Sub

    Option Explicit

    ‘ Class constants
    Private Const msTAB As String = vbTab

    ‘ Class variables
    Private mrSelection As Range
    Private mrTarget As Range

    ‘ Class Properties
    ‘   Selection
    Property Get TheSelection() As Range
        Set TheSelection = mrSelection
    End Property
    Property Let TheSelection(rng As Range)
        Set mrSelection = rng
    End Property

    ‘   Target
    Property Get Target() As Range
        Set targert = mrTarget
    End Property
    Property Let Target(rng As Range)
        ‘ The target can only be one cell, so if more than
       ‘ one cell is chosen, set the range to the
       ‘ upper leftmost cell.
       If rng.Count > 1 Then
            Set mrTarget = rng.Cells(1, 1)
        Else
            Set mrTarget = rng
        End If
    End Property

    ‘ Class methods

    Sub ExtractUniques()
       
        ‘ Variable declarations
       Dim rngCell As Range
        Dim col As Collection
        Dim iColCnt As Integer, i As Integer
        Dim vValue As Variant
       
        ‘ Create a new collection.
       Set col = New Collection
       
        ‘ Get the number of columns in the range
       iColCnt = mrSelection.Columns.Count
        ‘ If the column count is greater than 1, resize it to 1 column.
       If iColCnt > 1 Then Set mrSelection = mrSelection.Resize(, 1)
       
        ‘ Turn off updating.
       Application.ScreenUpdating = False

        ‘ Add each unique item to the collection.
       For Each rngCell In mrSelection.Cells
            vValue = “”
            ‘ If the column count is great than one, add the whole
           ‘ row of data in teh selected range. We’ll split it out
           ‘ later.
           If iColCnt > 1 Then
                For i = 0 To iColCnt – 1
                    ‘ Add all the data from the selected rows to the variable,
                   ‘ separating them by a tab.
                   vValue = vValue & rngCell.Offset(0, i).Value & msTAB
                Next i
            Else
                vValue = rngCell.Value
            End If
            ‘ Temporarily turn off error handling.
           On Error Resume Next
            ‘ Add to the collection.
           col.Add CStr(vValue), CStr(vValue)
            ‘ Turn error handling back on.
           On Error GoTo 0
        Next rngCell
       
        ‘ Write the data back out to the target.
       i = 1
        For i = 1 To col.Count
            mrTarget.Offset(i – 1, 0).Value = col(i)
        Next i
       
        ‘ If the selection column count is greater than 1,
       ‘ then convert the output text to multiple columns
       ‘ using text to columns.
       If iColCnt > 1 Then
            mrTarget.Parent.Activate
            mrTarget.Select
            Range(Selection, Selection.Offset(col.Count – 1, 0)).Select
            Selection.TextToColumns Destination:=Range(Selection.Address), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=False
        End If
       
        ‘ Turn on updating and kill the collection object.
       Application.ScreenUpdating = True
        Set col = Nothing
           
    End Sub

  16. A slight modification, using a selection:

    Sub enkel()
      Dim sq As Variant
      Dim j As Long
     
      If Selection.Columns.Count = 1 Then
        sq = Application.WorksheetFunction.Transpose([b]Selection[/b].SpecialCells(xlCellTypeConstants))
        For j = 1 To UBound(sq)
          If UBound(Filter(sq, sq(j))) > 0 Then sq(j) = “#”
        Next
        sq = Filter(sq, “#”, False)
        Sheets(1).[K1].Resize(UBound(sq) + 1) = Application.WorksheetFunction.Transpose(sq)
      End If
    End Sub
  17. In my limited tests, it appears that the Filter function cannot distinguish between…

    “Filler 1? and “Filler 10? or
    “Filler 1? and “Filler 12?.

    One or the other doesn’t get included in the unique listing.

  18. @Jim

    You are quite right. To solve this:

    Sub enkel()
      Dim sq As Variant
      Dim j As Long
     
      If Selection.Columns.Count = 1 Then
        sq = Application.WorksheetFunction.Transpose(Selection.SpecialCells(xlCellTypeConstants))
        For j = 1 To UBound(sq)
          sq=split(replace(“|” & join(sq,“|”) & “|”,“|” & sq(j) & “|”,“”) & “|” & sq(j),“|”)
        Next
        Sheets(1).[K1].Resize(UBound(sq) + 1) = Application.WorksheetFunction.Transpose(sq)
      End If
    End Sub
  19. @Hans
    I tried to implement your solution but was unable to get it to work. I think there are three issues. Your replacement string is “” so the two elements on either side get concatenated. You start with a 1-based array and move to a 0-based array so the 2nd element gets skipped. And the For termination value I believe is only evaluated at the beginning, but if there are many repeats, the array can shrink quickly, so near the end it will be evaluating non-existant array elements.

    I also wonder about how large a string can be – and as such, will this only work with small lists?

  20. @Charlie

    A simpler solution:

    Sub enkel()
      Dim sq As Variant
      Dim j As Long
     
      If Selection.Columns.Count = 1 Then
        sq = Application.WorksheetFunction.Transpose(Selection.SpecialCells(xlCellTypeConstants))
        For j = 1 To UBound(sq)
          If InStr(c0 amp; “|”, “|” amp; sq(j) amp; “|”) = 0 Then c0 = c0 amp; “|” amp; sq(j)
        Next
        Sheets(1).[K1].Resize(UBound(Split(c0, “|”))) = Application.WorksheetFunction.Transpose(Split(Mid(c0, 2), “|”))
      End If
    End Sub

    PS. A String can contain more then 2 million characters. So don’t worry.

  21. Hans
    nice solution for moderate amount of data getting appended to string. But if large amount; each one causes the recopying of a bigger and bigger string and consume cobs of time as the string grows. A more general solution might allocate a large string and then lay data into with a Mid(bigstring,x,y)= approach, appending more space only when the allocated space was used…

  22. If you go for speed:

    Sub tst1()
      Dim t As Long, i As Long, c0 As String
       
      t = Timer
      Columns(1).SpecialCells(xlCellTypeConstants).AdvancedFilter xlFilterCopy, , [K1], True
      Debug.Print Timer – t
    End Sub

    I tested this one to 3 alternatives with a list of 8000 textstrings.
    Speed performance tst1:tst2:tst3:tst4 = 1:23:55:112

    Sub tst2()
      Dim t As Long, i As Long, c0 As String

      t = Timer
      Set colUnique = New Collection
      On Error Resume Next
      For Each cl In Columns(1).SpecialCells(xlCellTypeConstants)
        colUnique.Add cl, Format(cl)
      Next
      On Error GoTo 0
       
      i = 0
      For Each it In colUnique
        Range(“G1”).Offset(i, 0).Value = it
        i = i + 1
      Next
      Debug.Print Timer – t
    End Sub

    Sub tst3()
      Dim t As Long, i As Long, c0 As String
      t = Timer
      sq = Application.WorksheetFunction.Transpose(Columns(1).SpecialCells(xlCellTypeConstants))
      For i = 1 To UBound(sq)
        If InStr(“#” & c0, “#” & sq(i) & “|”) = 0 Then c0 = c0 & sq(i) & “|#”
      Next
      sq = Split(c0, “|#”)
      Cells(1, 4).Resize(UBound(sq) + 1) = WorksheetFunction.Transpose(sq)
      Debug.Print Timer – t
    End Sub
    Sub tst4()
      Dim t As Long, i As Long, c0 As String
       
      t = Timer
      sq = Split(“|” & Join(Application.WorksheetFunction.Transpose(Columns(1).SpecialCells(xlCellTypeConstants)), “|#|”) & “|”, “#”)
      For i = 0 To UBound(sq)
        If UBound(Filter(sq, sq(i))) > 0 Then sq(i) = “#”
      Next
      sq = Split(Replace(Join(Filter(sq, “#”, False), “#”), “|”, “”), “#”)
      Cells(1, 4).Resize(UBound(sq) + 1) = WorksheetFunction.Transpose(sq)
      Debug.Print Timer – t
    End Sub
  23. This is very easy without any programming:

    Values in A1:A30

    In B1 put value 1
    In B2 put the formula:
    =IF(ISERROR(MATCH(A2;$A$1:A1;0));MAX(B$1:B1)+1;””)
    copy formula down till B30

    In C1 put the value 1
    In C2 the formula =C1+1

    In D1 the formula:
    =INDEX(A$1:A$30;MATCH(C1;$B$1:$B$30;0))

    copy to D2

    Now copy C2:D2 down…

    In column D you have the A1:A30 unique values

  24. Code from my personal.xls file is below. Uses Excel’s advanced filter, so there must be a header, and pastes result to the right hand side, one column clear. One plus I like with advanced filter is handling mutliple columns to return all distinct possibilities.

  25. Sorry about the code tags. Should be

    Sub UniqueItems()

      On Error GoTo ErrorHandler
      With Selection
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, Cells.Find(what:=”*”, After:=Cells(1, 1), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2), Unique:=True
      End With

    ResumeHere:
      Exit Sub

    ErrorHandler:
      MsgBox Prompt:=”Something went wrong !!”, Buttons:=vbCritical, Title:=”Error …”
      GoTo ResumeHere
    End Sub


Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.