使用VBA读取AutoFilter标准

我正在与一个Excel工作簿，我想在一列中find所有的唯一值。

我有代码，通过循环遍历所有的行，并为每一行循环通过迄今为止看到的值的集合，并检查是否以前见过。

它是这样工作的。

Function getUnique(Optional col As Integer) As Collection If col = 0 Then col = 2 Dim values As Collection Dim value As Variant Dim i As Integer Dim toAdd As Boolean i = 3 'first row with data Set values = New Collection Do While Cells(i, col) <> "" toAdd = True For Each value In values If Cells(i, col).value = value Then toAdd = False Next value If toAdd Then values.Add (Cells(i, col).value) i = i + 1 Loop Set getUnique = values End Function 

但是，Excel AutoFilter能够更快地find这些值。 有没有办法来过滤，然后读取唯一值？

我试过使用AutoFilter.Filters对象，但所有的.ItemX.Criteria1值都有一个“应用程序定义或对象定义的错误”（在ActiveSheet.AutoFilter.Filters上使用手表）。

Answer 1

这并不完全符合你所描述的内容，我认为它的处理效率不高，因为它正在检查每个单元对每个值的影响。

我认为这可能是低效的，因为随着values集合的增长，第二个循环将花费更长的时间来处理。

你可以得到一些改善，如果你退出你的嵌套早期：

  Do While Cells(i, col) <> "" For Each value In values If Cells(i, col).value = value Then toAdd = False Else: values.Add (Cells(i, col).value) Exit For '### If the value is found, there's no use in checking the rest of the values! End If Next value i = i + 1 Loop 

但是我觉得一本字典可能会给你提升性能。 这样，我们不需要循环集合，我们只是使用字典的.Exists方法。 如果它不存在，我们增加收集，如果它，我们不。 然后函数仍然返回唯一的集合。

 Function getUnique(Optional col As Integer) As Collection If col = 0 Then col = 2 Dim values As Object Dim value As Variant Dim i As Integer Dim toAdd As Boolean Dim ret as New Collection i = 3 'first row with data Set values = CreateObject("Scripting.Dictionary") With Cells(i, col) Do While .Value <> "" If Not values.Exists(.Value) values(.Value) = 1 ret.Add(.Value) '## Add the item to your collection Else '## Count the occurences, in case you need to use this later values(.Value) = values(.Value) + 1 End If i = i + 1 Loop Set getUnique = ret End Function 

Answer 2

AdvancedFilter方法可能在这里派上用场，产生更清晰，更容易维护的代码。 只要你从另一个VBA模块调用这个函数，而不是从一个单元中调用。

 Function getUnique(Optional col As Integer) As Collection If col = 0 Then col = 2 Dim values As Collection Dim value As Variant Dim i As Integer i = 3 'first row with data Range(Cells(i, col), Cells(Rows.Count, col).End(xlUp)).AdvancedFilter xlFilterCopy, CopyToRange:=Cells(1, Columns.Count) Set values = New Collection Dim cel As Range For Each cel In Range(Cells(1, Columns.Count), Cells(1, Columns.Count).End(xlDown)) values.Add cel.value Next Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Clear Set getUnique = values End Function 

testing这个子：

 Sub Test() Dim c As Collection Set c = getUnique(4) For i = 1 To c.Count Debug.Print c.Item(i) Next End Sub