VBA：将范围内的不同值添加到新范围答案

【问题标题】：VBA: adding distinct values in a range to a new rangeVBA：将范围内的不同值添加到新范围
【发布时间】：2012-05-09 22:18:56
【问题描述】：

我在 Sheet1 的 A 列中有一个未排序的名称列表。其中许多名称在列表中出现多次。

在 Sheet2 列 A 我想要一个按字母顺序排序的名称列表，没有重复值。

使用 VBA 实现此目的的最佳方法是什么？

目前我看到的方法包括：

以 CStr(name) 为键创建一个集合，循环遍历范围并尝试添加每个名称；如果有错误它不是唯一的，忽略它，否则将范围扩大 1 个单元格并添加名称
与 (1) 相同，但忽略错误。循环完成后，集合中只有唯一值：然后将整个集合添加到范围中
在范围上使用匹配工作表功能：如果不匹配，则将范围扩大一个单元格并添加名称
也许对数据选项卡上的“删除重复项”按钮进行了一些模拟？（还没有研究过）

【问题讨论】：

我会选择选项 4。1) 录制宏 2) 将 Col A 复制到第二张表 3) 如果您使用 Excel 2007，请选择 Col A 并按下数据选项卡下的删除重复项按钮4) 对数据进行排序 :) 试一试，如果遇到困难，请回复 :)
+1 表示悉达多的回答。这应该很容易。
这样的问题已经被问过很多次了...看看以前的答案 (here for example)，尝试一下，看看它是否有效，如有任何问题，请与我们联系。 This 和 this 对您也很有用。

标签： vba excel

【解决方案1】：

我真的很喜欢 VBA 中的字典对象。它不是本机可用的，但它非常有能力。您需要添加对Microsoft Scripting Runtime 的引用，然后您可以执行以下操作：

Dim dic As Dictionary
Set dic = New Dictionary
Dim srcRng As Range
Dim lastRow As Integer

Dim ws As Worksheet
Set ws = Sheets("Sheet1")

lastRow = ws.Cells(1, 1).End(xlDown).Row
Set srcRng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1))

Dim cell As Range

For Each cell In srcRng
    If Not dic.Exists(cell.Value) Then
        dic.Add cell.Value, cell.Value   'key, value
    End If
Next cell

Set ws = Sheets("Sheet2")    

Dim destRow As Integer
destRow = 1
Dim entry As Variant

'the Transpose function is essential otherwise the first key is repeated in the vertically oriented range
ws.Range(ws.Cells(destRow, 1), ws.Cells(dic.Count, 1)) = Application.Transpose(dic.Items)

【讨论】：

您可以使用 dic.keys 一步将字典键数组转置到范围。试试看:)
哦，很有趣。我喜欢。我更新了答案以显示此更改！

【解决方案2】：

正如您所建议的，某种字典是关键。我会使用 Collection - 它是内置的（与 Scripting.Dictionary 相反）并且可以完成工作。

如果“最佳”是指“快速”，第二个技巧是不要单独访问每个单元格。而是使用缓冲区。即使有数千行输入，下面的代码也会很快。

代码：

' src is the range to scan. It must be a single rectangular range (no multiselect).
' dst gives the offset where to paste. Should be a single cell.
' Pasted values will have shape N rows x 1 column, with unknown N.
' src and dst can be in different Worksheets or Workbooks.
Public Sub unique(src As Range, dst As Range)
    Dim cl As Collection
    Dim buf_in() As Variant
    Dim buf_out() As Variant
    Dim val As Variant
    Dim i As Long

    ' It is good practice to catch special cases.
    If src.Cells.Count = 1 Then
        dst.Value = src.Value   ' ...which is not an array for a single cell
        Exit Sub
    End If
    ' read all values at once
    buf_in = src.Value
    Set cl = New Collection
    ' Skip all already-present or invalid values
    On Error Resume Next
    For Each val In buf_in
        cl.Add val, CStr(val)
    Next
    On Error GoTo 0

    ' transfer into output buffer
    ReDim buf_out(1 To cl.Count, 1 To 1)
    For i = 1 To cl.Count
        buf_out(i, 1) = cl(i)
    Next

    ' write all values at once
    dst.Resize(cl.Count, 1).Value = buf_out

End Sub

【讨论】：