VBA过滤器列存储另一列的唯一值答案

【问题标题】：VBA Filter Column Store Unique Values of Another ColumnVBA过滤器列存储另一列的唯一值
【发布时间】：2021-03-13 03:50:46
【问题描述】：

我正在努力完成以下工作。

过滤列 A
从 B 列获取唯一值

所以给出下表...

我想过滤 A 列中的“One”，然后得到一个可以像这样粘贴到 C 列的数组...

我尝试过使用字典，但对它的工作原理知之甚少。可能有数千行，因此速度可能是一个问题，如果没有必要，我宁愿不要循环遍历每一行。

我见过使用高级过滤器恢复列的唯一值的解决方案，但从来没有过滤一列，然后使用过滤后的结果来获取唯一值列表。

我尝试过的代码示例（部分）：

On Error Resume Next
    enterpriseReportSht.ShowAllData
On Error GoTo 0
With enterpriseReportSht
    .AutoFilterMode = False
    With .Range(Cells(1, 1).Address, Cells(entRptLR, entRptLC).Address)
        .AutoFilter Field:=manLevel2CN, Criteria1:=userInputsArr(i, manLevel2InputCN)
        '.SpecialCells(xlCellTypeVisible).Copy Destination:=resultsSht.Range("A1")
    End With
End With
filteredColArr = enterpriseReportSht.UsedRange.columns(manLevel4CN).Value
RemoveDuplicatesFromArray (filteredColArr)

使用此功能：

Public Function RemoveDuplicatesFromArray(sourceArray As Variant)
Dim duplicateFound As Boolean
Dim arrayIndex As Integer, i As Integer, j As Integer
Dim deduplicatedArray() As Variant

arrayIndex = -1
deduplicatedArray = Array(1)

For i = LBound(sourceArray) To UBound(sourceArray)
    duplicateFound = False

    For j = LBound(deduplicatedArray) To UBound(deduplicatedArray)
        If sourceArray(i) = deduplicatedArray(j) Then
            duplicateFound = True
            Exit For
        End If
    Next j

    If duplicateFound = False Then
        arrayIndex = arrayIndex + 1
        ReDim Preserve deduplicatedArray(arrayIndex)
        deduplicatedArray(arrayIndex) = sourceArray(i)
    End If
Next i

RemoveDuplicatesFromArray = deduplicatedArray
End Function

我担心的是它没有抓取过滤后的数据。我相信它抓住了一切。我也收到了删除重复功能的错误。

【问题讨论】：

什么版本的 Excel？如果您有 Office 365，则可以使用工作表公式执行此操作。

标签： excel vba

【解决方案1】：

这应该可以满足您使用字典的要求。

您可以通过将范围加载到数组中并对其进行迭代来加速它，但是使用过滤范围以及获取二维数组的上限有点痛苦，您需要首先将其转置为一维数组。除非您注意到速度真的很慢，否则可能不值得。我用 15k 行测试它是

    Dim i As Long
    Dim lr As Long
    Dim filterrange As Range
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    
    With Sheet1 'Change as needed
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set filterrange = .Range(.Cells(1, 1), .Cells(lr, 2))
        filterrange.AutoFilter 1, "One"
        
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row 'Only really necessary if you have a lot of rows
        
        For i = 1 To lr
            If .Rows(i).EntireRow.Hidden = False Then
                If Not dict.exists(.Cells(i, 2).Value) Then
                    dict.Add .Cells(i, 2).Value, ""
                End If
            End If
        Next i
        filterrange.AutoFilter
        
        Dim key As Variant
        i = 1
        For Each key In dict
            .Cells(i, 3).Value = key
            i = i + 1
        Next key
    End With

【讨论】：

在我解决这个问题时有几个问题。 1）我有这个循环运行，因为它会发生多次。我需要重置字典吗？在我最初的运行期间，它看起来每次都在添加。 2) 列表在粘贴到工作表之前可以排序吗？
我可以使用dict.RemoveAll 清除字典。我还使用了我在另一个网站上找到的功能来按键排序。谢谢。根据我最初的要求，这似乎工作得很好。运行确实需要很长时间，大约 12 分钟，因为我在一个循环中运行了很多次。
是的 dict.removeall 将起作用或将集合移动到外部循环的开头以重置变量。如果将范围加载到数组中，它应该会更快。不确定您使用的是什么类型的排序，如果它是一个气泡，您可以使用快速排序来加快它。
我发现处理时间长的根本原因是它创建的公式与庞大的数据集相关联。我做了一个 value=value 来复制粘贴，并将其缩短到 3 分钟。那是令人满意的。感谢你的帮助。我会选择这个答案，因为它已经足够并且满足了我声明的需求。

【解决方案2】：

假设你有 Office 365 并且没有提到只有 VB 的解决方案，这可以使用工作表函数本身来实现

=UNIQUE(FILTER(B:B,A:A=A1))

【讨论】：

谢谢。我相信有人会欣赏这个答案。然而，这不是我想要的。