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
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.
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?
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
An Alternate way
Sub CopyUniqueItems()
If Selection.Columns.Count > 1 Or Selection.Rows.Count
Sub CopyUniqueItems()
If Selection.Columns.Count > 1 Or Selection.Rows.Count
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.
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…
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
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
Very similar to John Walkenbach’s method in http://j-walk.com/ss/Excel/eee/eee004.txt.
What’s the difficulty with using Data…Filter…Advanced Filter with “Unique records only” checked and the “Copy to another location” option button selected?
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.
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.
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}
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
I like using Dictionary.
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
[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.
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
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.
David: That link doesn’t work. I think this is the new one http://spreadsheetpage.com/index.php/eee/issue_no_4_april_30_1999/
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.
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
A slight modification, using a selection:
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
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.
@Jim
You are quite right. To solve this:
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
@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?
@Charlie
A simpler solution:
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.
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…
@Hans:
Looks slick
If you go for speed:
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
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
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
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
[…] terms of speed goes. Refer to this page for a readymade piece of code, that runs like a darling! (http://www.dailydoseofexcel.com/archives/2008/12/11/create-unique-list-from-selected-cells/). Again, I’m not very versatile with Collections, so I can’t explain much. But […]
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
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.
Sorry about the code tags. Should be
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