Make a new column without duplicates 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-duplicate

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:

1. This is code for any Excel range, not just the single-column range you asked for.
2. This function tolerates cells with errors, which are difficult to handle in VBA.
3. 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