vba 从指定列复制单元格，删除重复项
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/7090920/
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
Copy cells from specified column, removing duplicates
提问by Jandrejc
I'm newbie in VBA, what I need to do is to copy rows from specified column into a column on the other worksheet, but I want to copy just one occurance of each word, for example
我是 VBA 新手，我需要做的是将指定列中的行复制到另一个工作表上的列中，但我只想复制每个单词的一次出现，例如
Column "F"
dog
dog
cat
dog
In the result I need to have new Worksheet called "Animals" with:
在结果中，我需要有一个名为“Animals”的新工作表，其中包含：
Column "A" Column "B"
1 dog
2 cat
回答by Xav
Do you need to do this in VBA at all?
您是否需要在 VBA 中执行此操作？
If you just want to get a unique copy of your list, select the unsorted, non-unique column contents including the header, then hit the Advanced... button on the Sort and Filter pane of the Data ribbon. You can ask it to copy to another location and tick Unique records only.
如果您只想获得列表的唯一副本，请选择包括标题在内的未排序的、非唯一的列内容，然后点击数据功能区的排序和筛选窗格上的高级...按钮。您可以要求它复制到另一个位置并勾选仅唯一记录。
Recording this activity and looking at the VBA, this is how it looks:
记录此活动并查看 VBA，它是这样的：
Range("A1:A4").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
回答by aevanko
Here is a sub routine that will do exactly what you want: slap a list of unique elements in Sheet1 column F into column A of sheet2 and rename the sheet "animals". You could tweak this so that instead of it changing the name of sheet2 it can create a new sheet if you like.
这是一个可以完全按照您的要求执行的子例程：将 Sheet1 列 F 中的唯一元素列表添加到 sheet2 的 A 列中，然后将工作表重命名为“animals”。您可以对此进行调整，这样就可以根据需要创建一个新工作表，而不是更改 sheet2 的名称。
Sub UniqueList()
Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Sheet1.Activate
lastRow = Sheet1.Cells(Rows.count, "F").End(xlUp).row
On Error Resume Next
For i = 1 To lastRow
If Len(cells(i, "F")) <> 0 Then
dictionary.Add cells(i, "F").Value, 1
End If
Next
Sheet2.range("a1").Resize(dictionary.count).Value = _
Application.Transpose(dictionary.keys)
Application.ScreenUpdating = True
MsgBox dictionary.count & " unique cell(s) were found and copied."
End Sub
How it works:I use a dictionary file, which will automatically take out any dupes, then slap the list of entries into sheet2.
它是如何工作的：我使用一个字典文件，它会自动取出任何欺骗，然后将条目列表放入 sheet2。
回答by JMax
here is a solution:
这是一个解决方案：
Option Explicit
Sub copyNoDuplicates()
Dim rLastCell As Range
Dim cell As Range, i As Long
Dim cAnimals As Collection
Set cAnimals = New Collection
With ActiveWorkbook.Worksheets("Sheet1")
'Find last used cell
Set rLastCell = .Range("F65536").End(xlUp)
'Parse every animal and put it in a collection
On Error Resume Next
For Each cell In .Range("F2:F" & rLastCell.Row)
cAnimals.Add cell.Value, CStr(cell.Value)
Next cell
On Error GoTo 0
End With
With ActiveWorkbook.Worksheets("Sheet2")
For i = 1 To cAnimals.Count
.Range("A" & i).Value = i
.Range("B" & i).Value = cAnimals(i)
Next i
End With
End Sub
