從VBA中的過濾器提取唯一值的集合

Question

我有一個文件，其中的行跨8列擴展到數萬。 其中一列包含周末日期。 我必須計算該文件中存在的周末數。

是否可以提取數據，如下圖所示？

如果我們可以提取並獲得此集合的計數，那么問題就解決了。

請幫忙。

提前致謝！

Answer 1

下面將從A列中獲取一系列三個隨機的大寫字母（25K個值），將它們作為唯一鍵（13,382個值）放入字典中，並在排序之前將它們轉回到同一工作表的C列中。 往返大約需要0.072秒。

以下代碼要求您進入VBE的“工具”►“引用”並添加Microsoft腳本運行時。 這保存了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

結果應與此類似：

Answer 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

Answer 3

選擇單元格的范圍，或確保活動單元格在表中。

在“數據”選項卡上的“排序和篩選”組中，單擊“高級”。

數據選項卡上的排序和過濾器組

在“高級篩選器”對話框中，執行下列操作之一：

要在適當位置過濾單元格或表格的范圍，請單擊“在適當位置過濾列表”。

要將篩選器的結果復制到另一個位置，請執行以下操作：

單擊復制到另一個位置。

在“復制到”框中，輸入單元格引用。

或者，單擊“折疊對話框按鈕”圖像以暫時隱藏對話框，在工作表上選擇一個單元格，然后按“展開對話框按鈕”圖像。

選擇僅唯一記錄復選框，然后單擊確定。

所選范圍內的唯一值將復制到新位置。

Answer 4

您可以使用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

Answer 5

是的，“數據”標簽>>刪除重復項