从VBA中的过滤器中提取唯一值的集合

Posted 2023-02-27

【中文标题】从VBA中的过滤器中提取唯一值的集合

【英文标题】：Extracting the collection of unique values from a filter in VBA

【发布时间】：2015-10-31 16:26:49

【问题描述】：

我有一个文件，它的行扩展到 8 列中的数万行。一个特定的列包含周末日期。我必须计算此文件中存在的周末数。

有没有办法提取如下图所示的数据？

如果我们可以提取并得到这个集合的计数，那么问题就解决了。

请帮忙。

提前致谢！

【问题讨论】：

你可以基于数据透视表做类似的事情，它的模型暴露得很好。抱歉，我现在无法搜索更多内容。

嗯。我确实想到了，但想知道是否可以减少步骤和内存。

在内存中构建字典对象。

啊，这是一个有趣的解决方案。让我深入挖掘！！谢谢！

嗨 Jeeped，这对我不起作用，因为脚本不是 vba 环境的默认安装，我不允许在我正在编码的系统上安装任何新东西。 :(

【参考方案1】：

以下内容将从 A 列（25K 值）中取出一系列三个随机大写字母，将它们作为唯一键（13,382 个值）放入字典中，然后在对它们进行排序之前将它们转储回同一工作表上的 C 列.往返大约需要 0.072 秒。

以下代码要求您进入 VBE 的工具 ► 参考并添加 Microsoft Scripting Runtime。这包含 Scripting.Dictionary 的库定义。但是，如果使用 CreateObject("Scripting.Dictionary")，则不需要库引用。

Sub buildFilterList()
    Dim dMUSKMELONs As Object    'New Scripting.Dictionary
    Dim v As Long, w As Long, vTMPs As Variant

    Debug.Print Timer
    Set dMUSKMELONs = CreateObject("Scripting.Dictionary")

    With Worksheets("Sheet2")   '<-set this worksheet reference properly!
        vTMPs = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp)).Value2
        For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
            If Not dMUSKMELONs.Exists(vTMPs(v, 1)) Then _
                dMUSKMELONs.Add key:=vTMPs(v, 1), Item:=vbNullString
        Next v
        With .Cells(2, "C").Resize(dMUSKMELONs.Count, 1)
            .Value = Application.Transpose(dMUSKMELONs.Keys)
            .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlNo
        End With
        .Cells(2, "D") = dMUSKMELONs.Count
    End With

    dMUSKMELONs.RemoveAll
    Set dMUSKMELONs = Nothing

    Debug.Print Timer

End Sub

结果应该是这样的：

        

【讨论】：

吉普车非常感谢你——它就像一个魅力。但更重要的是，它为我打开了如何处理数据的新视野。

【参考方案2】：

要从过滤器对话框中的列中获取唯一值，您可以使用Range.RemoveDuplicates 方法。

例子：

' Index of Column which contains the weekend date
Const weekendDateColumn As Integer = 2

Sub GetUniques()
    ' Create copy of active sheet with data so original data remains unchanged
    ActiveSheet.Copy After:=ActiveSheet

    ' Call Range.RemoveDuplicates method which removes duplicates in 
    ' data besed on values in column 'weekendDateColumn'
    Dim data As Range
    Set data = ActiveSheet.Range("A1").CurrentRegion
    data.RemoveDuplicates Columns:=Array(weekendDateColumn), Header:=xlYes

    ' Get unique values into array
    Dim uniques As Variant
    uniques = data.CurrentRegion.Columns(weekendDateColumn).Value

    ' Clear data resize it to size of uniques and paste the uniques there
    data.Clear
    data.Resize(UBound(uniques, 1), 1).Value = uniques
End Sub

【参考方案3】：

选择单元格范围，或确保活动单元格在表格中。

在“数据”选项卡的“排序和筛选”组中，单击“高级”。

“数据”选项卡上的“排序和筛选”组

在“高级过滤器”对话框中，执行以下操作之一：

要就地过滤单元格或表格范围，请点击就地过滤列表。

要将过滤器的结果复制到另一个位置，请执行以下操作：

点击复制到另一个位置。

在“复制到”框中，输入单元格引用。

或者，单击折叠对话框按钮图像以暂时隐藏对话框，选择工作表上的一个单元格，然后按展开对话框按钮图像。

选中唯一记录复选框，然后单击确定。

所选范围内的唯一值被复制到新位置。

【参考方案4】：

是的，数据选项卡 >> 删除重复项

【参考方案5】：

您可以使用 ADODB 连接到相应的工作表，并对工作表发出 SQL 语句：

Dim datasourcePath As String
datasourcePath = "C:\path\to\excel\file.xlsx"

Dim connectionString As String
connectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & datasourcePath & """;" & _
    "Extended Properties=""Excel 12.0;HDR=No""

Dim sql As String
sql = "SELECT DISTINCT F1 FROM [Sheet1$]" 'F1 is an autogenerated field name

Dim rs As New ADODB.Recordset
rs.Open sql, connectionString

Do Until rs.EOF
    Debug.Print rs("F1")
Loop