分别获取多列的唯一值

Question

我的 function 有什么问题，它加载了两个不同的列A和B并将列A的唯一值粘贴到列M和N中。

我想为 7 列重复此 function。

我将感谢您在这方面的帮助。

Sub GetUniques()

Dim d As Object, c As Variant, i As Long, lr As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long
Set d = CreateObject("Scripting.Dictionary")

lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("A2:A" & lr)

lr2 = Cells(Rows.Count, 2).End(xlUp).Row
e = Range("B2:B" & lr2)

For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i

For i = 1 To UBound(e, 1)
  d(e(i, 1)) = 1
Next i

Range("M2").Resize(d.Count) = Application.Transpose(d.keys)
Range("N2").Resize(d.Count) = Application.Transpose(d.keys)
End Sub

Answer 1

看起来您的计划是为每一列以及循环和转置语句设置一个lr变量。 您可以通过将代码嵌套在列循环中来避免这种情况。

当前的列范围在此处进行了硬编码（ A to E ），但可以根据需要将其更新为动态的。 output 也被硬编码为在输入列右侧删除 9 列。 这与A to J 、 B to K等一致。

---

Sub GetUniques()

Dim c As Variant, i As Long, lr As Long, col As Long
Dim d As Object

For col = 1 To 5     'Column A to E

    Set d = CreateObject("Scripting.Dictionary")
    
        lr = Cells(Rows.Count, col).End(xlUp).Row
        c = Range(Cells(2, col), Cells(lr, col))
    
        For i = 1 To UBound(c, 1)
            d(c(i, 1)) = 1
        Next i
    
        Cells(2, col + 9).Resize(d.Count) = Application.Transpose(d.keys)
    
    Set d = Nothing

Next col


End Sub

---

Answer 2

为了完整起见，我添加了UNIQUE - 解决方案：

您可以在J2中使用手动公式： =UNIQUE(A:E,TRUE) - 第二个参数告诉UNIQUE每列输出唯一值 -> 它将从J溢出到N 。

您也可以在 VBA 例程中使用此公式：

Public Sub writeUniqueValues(rgSource As Range, rgTargetTopLeftCell As Range)

With rgTargetTopLeftCell
    .Formula2 = "=UNIQUE(" & rgSource.Address & ",TRUE)"
    With .SpillingToRange
       .Value = .Value 'this will replace the formula by values
    End With
End With

End Sub

然后你可以像这样使用这个子：

Public Sub test_writeUniqueValues()

With ActiveSheet 'be careful: you should always use explicit referencing
    Dim lr As Long
    lr = .Cells(Rows.Count, 1).End(xlUp).Row

    writeUniqueValues .Range("A2:E" & lr), .Range("J2")
End With

End Sub

比较两种解决方案的性能（使用公式与使用字典）会很有趣......