分別獲取多列的唯一值

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

比較兩種解決方案的性能（使用公式與使用字典）會很有趣......