在拆分范围Excel VBA中查找唯一值

Question

我正在excel中创建一个动态搜索，最终给了我一个分割范围（例如[A4：D4，A6：D6，A8：D8]）。我想提取此拆分范围的每一列的唯一值，然后将它们复制到新的工作表中。我已经看到了许多寻找唯一值的解决方案，但没有一个能够在这样的分割范围内工作。 谢谢！

到目前为止我已经完成的代码（给我一个错误）：

Dim i As Long, j As Variant
j = dbws.Application.Transpose("$A$3:$D$3,$A$6:$D$6,$A$9:$D$9") '<== chooses unique cells for dropdown
With CreateObject("Scripting.Dictionary")
For Each i In j
.Item(i) = i
Next
ws.Cells(1, Colcount).Resize(.count) = Application.Transpose(.Keys)
End With

Answer 1

您可以使用词典字典：

Option Explicit
Public Sub CopyUniqueValues()
    Dim unionRng As Range, rng As Range, rng2 As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Set unionRng = Union([A4:D4], [A6:D6], [A8:D8])
    Application.ScreenUpdating = False

    For Each rng In unionRng.Areas
        For Each rng2 In rng.Cells
            If Not dict.exists(rng2.Column) Then
                dict.Add (rng2.Column), CreateObject("Scripting.Dictionary")
                dict(rng2.Column).Add rng2.Value, 1
            Else
                If Not dict(rng2.Column).exists(rng2.Value) Then
                    dict(rng2.Column).Add rng2.Value, 1
                End If
            End If
        Next rng2
    Next rng

    Dim dictOutput As Object, key1 As Variant, key2 As Variant
    Set dictOutput = CreateObject("Scripting.Dictionary")

    For Each key1 In dict.keys
        dictOutput.Add key1, dict(key1).keys
    Next
    With Worksheets("Sheet2")
         For Each key1 In dictOutput.keys
             .Columns(key1).Range("A1").Resize(UBound(dictOutput(key1)) + 1, 1) = Application.WorksheetFunction.Transpose(dictOutput(key1))
         Next key1
    End With
    Application.ScreenUpdating = True
End Sub

---

数据：

---

数据集：

| 1 | 1 | 10 | 11 |
| 1 | 2 | 10 | 12 |
| 1 | 3 | 10 | 13 |
| 1 | 4 | 10 | 14 |
| 1 | 5 | 10 | 15 |