VBA：将范围内的不同值添加到新范围
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/10524897/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA: adding distinct values in a range to a new range
提问by Swiftslide
I have an unsorted list of names in Sheet1, Column A. Many of these names appear more than once in the list.
我在 Sheet1 的 A 列中有一个未排序的名称列表。其中许多名称在列表中出现不止一次。
On Sheet2 Column A I want an alphabetically sorted list of the names with no duplicate values.
在 Sheet2 Column AI 上需要一个按字母顺序排序的名称列表，没有重复的值。
What is the optimal method of achieving this using VBA?
使用 VBA 实现这一目标的最佳方法是什么？
Methods I have seen so far include:
到目前为止，我看到的方法包括：
- Making a collection with CStr(name) as the key, looping through the range and trying to add each name; if there is an error it is not unique, ignore it, else expand the range by 1 cell and add the name
- Same as (1), except ignore about the errors. When the loop is complete, only unique values will be in the collection: THEN add the whole collection to the range
- Using the match worksheet function on the range: if no match, expand the range by one cell and add the name
- Maybe some simulation of the "remove duplicates" button on the data tab? (haven't looked into this)
- 创建一个以 CStr(name) 为键的集合，循环遍历范围并尝试添加每个名称；如果有错误，它不是唯一的，忽略它，否则将范围扩大 1 个单元格并添加名称
- 与 (1) 相同，只是忽略错误。循环完成后，集合中将只有唯一值：然后将整个集合添加到范围
- 在范围上使用匹配工作表功能：如果不匹配，则将范围扩大一个单元格并添加名称
- 也许对数据选项卡上的“删除重复项”按钮进行一些模拟？（没研究过这个）
回答by Brad
I really like the dictionary object in VBA. It's not natively available but it's very capable. You need to add a reference to Microsoft Scripting Runtimethen you can do something like this:
我真的很喜欢 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)
回答by Torben Klein
As you suggested, a dictionary of some sort is the key. I would use a Collection - it is builtin (in contrary to Scripting.Dictionary) and does the job.
正如你所建议的，某种字典是关键。我会使用一个集合 - 它是内置的（与 Scripting.Dictionary 相反）并且可以完成这项工作。
If by "optimal" you mean "fast", the second trick is to not access each cell individually. Instead use a buffer. The below code will be fast even with thousands of rows of input.
如果“最佳”是指“快速”，则第二个技巧是不要单独访问每个单元格。而是使用缓冲区。即使有数千行输入，下面的代码也会很快。
Code:
代码：
' 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
