Make a new column without duplicates VBA? - vba

Question

I have a column of cells whose values are something like this:
a
a
b
b
c
c
c
c
d
e
f
f
etc.
I'm looking to take the non-duplicated values and paste them into a new column. My pseudocode for this is as follows:
ActiveSheet.Range("a1").End(xlDown).Select
aend = Selection.Row
for acol= 1 to aend
ActiveSheet.Range("b1").End(xlDown).Select
bend = Selection.Row
'if Cells(1,acol).Value <> any of the values in the range Cells(2,1).Value
'to Cells(2,bend).Value, then add the value of Cells(1,acol) to the end of
'column b.
Does my logic in this make sense? I'm not sure how to code the commented portion. If this isn't the most efficient way to do it, could someone suggest a better way? Thanks so much!

Answer 1

Depending on which version of Excel you are using, you can use some built-in Excel functionality to obtain what you want- the whole solution depends on your level of skill with VBA.
Excel 2003:
You can use the Advancedfilter method (documentation) of your range to obtain the unique values and copy them to your target area. Example:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
End With
Where B1 is the first cell of the column you wish to copy the unique values to. The only problem with this method is that the first row of the source column ("A1") will be copied to the target range even if it is duplicated. This is because the AdvancedFilter method assumes that the first row is a header.
Therefore, adding an additional code line we have:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
.Range("B1").Delete Shift:=xlShiftUp
End With
Excel 2007 / 2010:
You can use the same method as above, or use the RemoveDuplicates method (documentation). This is similar to the AdvancedFilter method, except that RemoveDuplicates works in-place, which means you need to make a duplicate of your source column and then perform the filtering, for example:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).Copy Destination:=.Range("B1")
.Range("B1", .Range("B1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End With
The final parameter Header controls whether the first cell of the source data is copied to the destination (if it's set to true then the method similarly to the AdvancedFilter method).
If you're after a "purer" method, then you can use a VBA Collection or dictionary - I am sure that someone else will offer a solution with this.

Answer 2

I use a collection, which can't have duplicate keys, to get the unique items from a list. Try to add each item to a collection and ignore the errors when there's a duplicate key. Then you'll have a collection with a subset of unique values
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A1:A12").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheet1.Range("B1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub

Answer 3

For completeness, I'm posting the Scripting.Dictionary method: it's the commonest alternative to using a VBA.Collection and it avoids the need to rely on error-handling in normal operation.
A VBA Function using the Scripting.Dictionary Object to Return Unique Values from an Excel Range Containing Duplicates:
Option Explicit
' Author: Nigel Heffernan
' May 2012 http://excellerando.blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
'
' You are advised to segregate this code from
' any proprietary or commercially-confidential
' source code, and to label it clearly. If you
' fail do do so, there is a risk that you will
' impair your right to assert ownership of any
' intellectual property embedded in your work,
' or impair your employers or clients' ability
' to do so if the intellectual property rights
' in your work have been assigned to them.
'
Public Function UniqueValues(SourceData As Excel.Range, _
Optional Compare As VbCompareMethod = vbBinaryCompare _
) As Variant
Application.Volatile False
' Takes a range of values and returns a single-column array of unique items.
' The returned array is the expected data structure for Excel.Range.Value():
' a 1-based 2-Dimensional Array with dimensions 1 to RowCount, 1 to ColCount
' All values in the source are treated as text, and uniqueness is determined
' by case-sensitive comparison. To change this, set the Compare parameter to
' to 1, the value of the VbCompareMethod enumerated constant 'VbTextCompare'
' Error values in cells are returned as "#ERROR" with no further comparison.
' Empty or null cells are ignored: they do not appear in the returned array.
Dim i As Long, j As Long, k As Long
Dim oSubRange As Excel.Range
Dim arrSubRng As Variant
Dim arrOutput As Variant
Dim strKey As String
Dim arrKeys As Variant
Dim dicUnique As Object
' Note the late-binding as 'object' - best practice is to create a reference
' to the Windows Scripting Runtime: this allows you to declare dictUnique as
' Dim dictUnique As Scripting.Dictionary and instantiate it using the 'NEW'
' keyword instead of CreateObject, giving slightly better speed & stability.
If SourceData Is Nothing Then
Exit Function
End If
If IsEmpty(SourceData) Then
Exit Function
End If
Set dicUnique = CreateObject("Scripting.Dictionary")
dicUnique.CompareMode = Compare
For Each oSubRange In SourceData.Areas ' handles noncontiguous ranges
'Use Worksheetfunction.countA(oSubRange) > 0 to ignore empty ranges
If oSubRange.Cells.Count = 1 Then
ReDim arrSubRng(1 To 1, 1 To 1)
arrSubRng(1, 1) = oSubRange.Cells(1, 1).Value
Else
arrSubRng = oSubRange.Value
End If
For i = LBound(arrSubRng, 1) To UBound(arrSubRng, 1)
For j = LBound(arrSubRng, 2) To UBound(arrSubRng, 2)
If IsError(arrSubRng(i, j)) Then
dicUnique("#ERROR") = vbNullString
ElseIf IsEmpty(arrSubRng(i, j)) Then
' no action: empty cells are ignored
Else
' We use the error-tolerant behaviour of the Dictionary:
' If you query a key that doesn't exist, it adds the key
dicUnique(CStr(arrSubRng(i, j))) = vbNullString
End If
Next j
Next i
Erase arrSubRng
Next oSubRange
If dicUnique.Count = 0 Then
UniqueValues = Empty
Else
arrKeys = dicUnique.keys
dicUnique.RemoveAll
ReDim arrOutput(1 To UBound(arrKeys) + 1, 1 To 1)
For k = LBound(arrKeys) To UBound(arrKeys)
arrOutput(k + 1, 1) = arrKeys(k)
Next k
Erase arrKeys
UniqueValues = arrOutput
Erase arrOutput
End If
Set dicUnique = Nothing
End Function
A couple of notes:
This is code for any Excel range, not just the single-column range you asked for.This function tolerates cells with errors, which are difficult to handle in VBA.This isn't Reddit: you can read the comments, they are an aid to understanding and generally beneficial to your sanity.

Answer 4

I would use a simple array, go through all the letters and check if the letter you are on is in the array:
Sub unique_column()
Dim data() As Variant 'array that will store all of the unique letters
c = 1
Range("A1").Select
Do While ActiveCell.Value <> ""
ReDim Preserve data(1 To c) As Variant
If IsInArray(ActiveCell.Value, data()) = False Then 'we are on a new unique letter and will add it to the array
data(c) = ActiveCell.Value
c = c + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
'now we can spit out the letters in the array into a new column
Range("B1").Value = "Unique letters:"
Dim x As Variant
Range("B2").Select
For Each x In data()
ActiveCell.Value = x
ActiveCell.Offset(1, 0).Select
Next x
Range("A1").Select
c = c - 1
killer = MsgBox("Processing complete!" & vbNewLine & c & "unique letters applied.", vbOKOnly)
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function