VBA unique values

[MrBramme]

Hi,


I'm tryin to find the best/fastest VBA method of find and listing unique value's. the first bit and end bit will be implementend in my current VBA, but basicly the idea is:


- A list of approx 8000 cases will have to be processed

- there will be around 100 unique values with variating counts

- the output will be inserted in another sheet and picked up in further analysis

- VBA because this will run weekly during a year with dynamic data, and i'd like to press a button and be done with it


anyway, this is the code i use now. This will cycle all cases in the current column and list the unique value's in sheet "unique" which will be added (plz note, i didn't include error handling if the sheet exists).

[pre]

Sub findunique()

Dim LastRow As Integer, StartRow As Integer, CurColumn As Integer
Dim x As Integer, y As Integer, z As Integer
Dim UniqueArray() As Variant
Dim IsInArray As Boolean

LastRow = ActiveSheet.UsedRange.Rows.Count
StartRow = 2 'just in case you use headers
CurColumn = Selection.Column
y = 0
ReDim Preserve UniqueArray(y)

For x = StartRow To LastRow
IsInArray = False 'reset
For z = LBound(UniqueArray) To UBound(UniqueArray)
If Cells(x, CurColumn) = UniqueArray(z) Then IsInArray = True
Next z
If IsInArray = False Then
ReDim Preserve UniqueArray(y)
UniqueArray(y) = ActiveSheet.Cells(x, CurColumn)
y = y + 1
End If
Next x

ActiveWorkbook.Sheets.Add.Name = "Unique"
For x = LBound(UniqueArray) To UBound(UniqueArray)
ActiveSheet.Range("A" & x + 1) = UniqueArray(x)
Next x

End Sub

[/pre]

 

[keymaster]

If you have Excel 2007 or above, leave it to Excel to remove the duplicates. There is a built-in feature called "Remove Duplicates" in data ribbon that can do this with just a click.


In case you want to automate it thru VBA, below code helps.

[pre]

Sub removeDups()
' Remove duplicates in the range1 and paste the output at pasteHere

Application.DisplayAlerts = False

Range("range1").Copy
Range("pasteHere").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range(Range("pasteHere"), Range("pasteHere").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo

Application.DisplayAlerts = True

End Sub

[/pre]

Just replace range1 and pasteHere with actual cell references or names.

 

[Krishnakumar]

Or you may find this function useful.


http://www.excelfox.com/forum/f12/extract-unique-values-range-69/


Kris

 

[MrBramme]

Perfect, thanks Chandoo. much simpler than my method I was so focussed on using an array i forgot the simplicity of built in actions ;-)


Hi Kris, thanks for the link! I'll try and look into it tonight for more insights

 

[shrivallabha]

Here is one more VBA route which generally works faster.

[pre]

Option Explicit
Public Sub GetUniques()
Dim i As Long
With CreateObject("Scripting.Dictionary") 'Create dictionary
.comparemode = vbTextCompare
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
'.exists checks if dictionary contains item
'If it doesn't then it adds
If Not .exists(Range("A" & i).Value) Then .Add Range("A" & i).Value, Range("A" & i).Value
Next i
'Paste all elements loaded in dictionary
Range("B1").Resize(.Count, 1) = Application.Transpose(.keys)
End With
End Sub

[/pre]

 

[DaveTurton]

For those with excel 2003 you can use an advanced filter and filter for unique values