做一个新的列没有重复的VBA？

我有一列单元格的值是这样的：

a a b b c c c c d e f f 

等等

我正在寻找采取非重复的值，并将其粘贴到一个新的列。 我的伪代码如下：

 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. 

我的逻辑是否有意义？ 我不知道如何编码评论部分。 如果这不是最有效的方法，有人可以build议一个更好的方法吗？ 非常感谢！

Answer 1

根据您使用的是哪个版本的Excel，您可以使用一些内置的Excelfunction来获得您想要的内容 – 整个解决scheme取决于您使用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 – 我相信别人会提供一个解决scheme。

Answer 2

我使用一个集合，它不能有重复的键，从列表中获取唯一的项目。 尝试将每个项目添加到集合，并在有重复键时忽略错误。 然后，您将拥有一个包含唯一值的子集的集合

 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 

Answer 3

为了完整起见，我发布了Scripting.Dictionary方法：这是使用VBA.Collection的最常见的select，它避免了在正常操作中依赖error handling的需要。

使用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 

几个注意事项：

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

Answer 4

我会用一个简单的数组，遍历所有的字母，并检查你所在的字母是否在数组中：

 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