Сделать новый столбец без дубликатов VBA?

В зависимости от того, какую версию Excel вы используете, вы можете использовать некоторые встроенные функции Excel для получения желаемого — все решение зависит от вашего уровня навыков работы с VBA.

Excel 2003:

Вы можете использовать метод Advancedfilter (документация) вашего диапазона, чтобы получите уникальные значения и скопируйте их в целевую область. Пример:

With ActiveSheet
    .Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
End With

Где B1 — это первая ячейка столбца, в который вы хотите скопировать уникальные значения. Единственная проблема с этим методом заключается в том, что первая строка исходного столбца («A1») будет скопирована в целевой диапазон, даже если она дублируется. Это связано с тем, что метод AdvancedFilter предполагает, что первая строка является заголовком.

Таким образом, добавив дополнительную строку кода, мы имеем:

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:

Вы можете использовать тот же метод, что и выше, или использовать метод RemoveDuplicates (документация). Это похоже на метод AdvancedFilter, за исключением того, что RemoveDuplicates работает на месте, что означает, что вам нужно создать дубликат исходного столбца, а затем выполнить фильтрацию, например:

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

Последний параметр Header определяет, копируется ли первая ячейка исходных данных в место назначения (если для него установлено значение true, то метод аналогичен методу AdvancedFilter).

Если вам нужен «более чистый» метод, вы можете использовать VBA Collection или dictionary - я уверен, что кто-то еще предложит решение с этим.

Я использую коллекцию, в которой не может быть повторяющихся ключей, чтобы получить уникальные элементы из списка. Попробуйте добавить каждый элемент в коллекцию и игнорировать ошибки при наличии повторяющегося ключа. Тогда у вас будет коллекция с подмножеством уникальных значений

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

Для полноты картины я публикую метод Scripting.Dictionary: это наиболее распространенная альтернатива использованию VBA.Collection, позволяющая избежать необходимости полагаться на обработку ошибок при нормальной работе.

Функция VBA, использующая объект Scripting.Dictionary для возврата уникальных значений из диапазона Excel, содержащего дубликаты:

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. Это код для любого диапазона Excel, а не только для диапазона с одним столбцом, о котором вы просили.
2. Эта функция допускает ячейки с ошибками, которые трудно обработать в VBA.
3. Это не Reddit: вы можете прочитать комментарии, они помогают понять и в целом полезны для вашего здравомыслия.

Я бы использовал простой массив, просмотрел все буквы и проверил, находится ли буква, на которой вы находитесь, в массиве:

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