创建一个没有重复 VBA 的新列？

Make a new column without duplicates VBA?

提问by sresht

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!

我在这方面的逻辑有意义吗？我不确定如何对注释部分进行编码。如果这不是最有效的方法，有人可以提出更好的方法吗？非常感谢！

回答by i_saw_drones

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 版本，您可以使用一些内置的 Excel 功能来获取您想要的内容 - 整个解决方案取决于您使用 VBA 的技能水平。

Excel 2003:

Excel 2003：

You can use the Advancedfiltermethod (documentation) of your range to obtain the unique values and copy them to your target area. Example:

您可以使用范围的Advancedfilter方法（文档）来获取唯一值并将它们复制到您的目标区域。例子：

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

Where B1is 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.

B1您希望将唯一值复制到的列的第一个单元格在哪里。这种方法的唯一问题是源列（“A1”）的第一行即使被复制，也会被复制到目标范围。这是因为 AdvancedFilter 方法假定第一行是标题。

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:

Excel 2007 / 2010：

You can use the same method as above, or use the RemoveDuplicatesmethod (documentation). This is similar to the AdvancedFilter method, except that RemoveDuplicatesworks in-place, which means you need to make a duplicate of your source column and then perform the filtering, for example:

您可以使用与上述相同的方法，也可以使用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

The final parameter Headercontrols 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).

最后一个参数Header控制是否将源数据的第一个单元格复制到目标（如果设置为 true，则方法类似于 AdvancedFilter 方法）。

If you're after a "purer" method, then you can use a VBA Collectionor dictionary- I am sure that someone else will offer a solution with this.

如果您追求“更纯粹”的方法，那么您可以使用 VBACollection或dictionary- 我相信其他人会为此提供解决方案。

回答by Dick Kusleika

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

回答by Nigel Heffernan

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.

为完整起见，我发布了 Scripting.Dictionary 方法：它是使用 VBA.Collection 的最常见替代方法，它避免了在正常操作中依赖错误处理的需要。

A VBA Function using the Scripting.Dictionary Object to Return Unique Values from an Excel Range Containing Duplicates:

使用 Scripting.Dictionary 对象从包含重复项的 Excel 范围返回唯一值的 VBA 函数：

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.

1. 这是任何 Excel 范围的代码，而不仅仅是您要求的单列范围。
2. 这个函数可以容忍有错误的单元格，这在 VBA 中很难处理。
3. 这不是 Reddit：您可以阅读评论，它们有助于理解并且通常有益于您的理智。

回答by tc_NYC

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