从列中获取唯一的值

我有这个问题，我仍然无法解决。 我大概可以使用Application.Transpose函数，但是这将获得列中的所有唯一值。 我想要做的是获得列中的唯一值，如果其他列值与特定的键匹配。

如果我使用Application.Transpose，C列中的所有唯一值将被采用。 我只想获得C中的唯一值，如果学生的名字是a 。并将其粘贴到新添加的工作簿的B列中。 我已经使用此代码筛选B中的唯一值并将其粘贴到新添加的工作簿的列A中。

 dim var as variant dim lastrow as long dim obj as object set obj = CreateObject("Scripting.Dictionary") var = Application.Transpose(Range([B1], Cells(Rows.count, "B").End(xlUp))) For lastRow = 1 To UBound(var, 1) obj(var(lastRow)) = 1 Next Set wb2 = Workbooks.Add Range("A1:A" & obj.count) = Application.Transpose(obj.keys) 

任何帮助表示赞赏。 谢谢！

Answer 1

非VBA解决scheme

1. 将数据复制到临时工作表。
2. selectCol A和Col B
3. 数据| 删除重复。
4. Col A上的AutoFilter为相关名称

VBA解决scheme（使用集合）

 Sub Sample() Dim ws As Worksheet Dim Col As New Collection, itm Dim lRow As Long, i As Long Dim tempAr As Variant Set ws = Sheet2 With ws lRow = .Range("A" & .Rows.Count).End(xlUp).Row tempAr = .Range("A2:B" & lRow).Value For i = LBound(tempAr) To UBound(tempAr) If tempAr(i, 1) = "a" Then On Error Resume Next '<~~ This will ensure a unique collection Col.Add tempAr(i, 2), CStr(tempAr(i, 2)) On Error GoTo 0 End If Next i End With For Each itm In Col Debug.Print itm 'or 'Debug.Print "a"; "-"; itm 'or export it to worksheet Next itm End Sub 

Answer 2

我同意Siddharth Rout使用Remove Duplicates的方法。

我调整了一下你的代码，使其工作。

 Sub Example() Dim wb2 As Excel.Workbook Dim var As Variant Dim x As Long Dim dict As Object Dim key As String Set dict = CreateObject("Scripting.Dictionary") var = Range("B1", Cells(Rows.Count, "C").End(xlUp)) For x = 1 To UBound(var, 1) If var(x, 1) = "a" Then key = var(x, 1) & "|" & var(x, 2) If Not dict.Exists(key) Then dict.Add key, var(x, 2) End If Next Set wb2 = Workbooks.Add wb2.ActiveSheet.Range("A1:A" & dict.Count) = Application.Transpose(dict.Items) End Sub 

---

我们还可以添加一个字典来存储唯一的值作为字典的关键字来存储唯一的标识符。 这样我们不必迭代数据两次。

 Sub Example() Dim wb2 As Excel.Workbook Dim var As Variant Dim x As Long Dim MainDict As Object, SubDict As Object Dim MainKey As String, SubKey, arSubKeys Set MainDict = CreateObject("Scripting.Dictionary") var = Range("B1", Cells(Rows.Count, "C").End(xlUp)) For x = 1 To UBound(var, 1) MainKey = var(x, 1) SubKey = var(x, 2) If MainDict.Exists(MainKey) Then Set SubDict = MainDict(MainKey) Else Set SubDict = CreateObject("Scripting.Dictionary") MainDict.Add MainKey, SubDict End If If Not SubDict.Exists(SubKey) Then SubDict.Add SubKey, vbNullString Next Set SubDict = MainDict("a") arSubKeys = SubDict.Keys Set wb2 = Workbooks.Add wb2.ActiveSheet.Range("A1:A" & UBound(arSubKeys) + 1) = Application.Transpose(SubDict.Keys) Set SubDict = MainDict("b") arSubKeys = SubDict.Keys Set wb2 = Workbooks.Add wb2.ActiveSheet.Range("A1:A" & UBound(arSubKeys) + 1) = Application.Transpose(SubDict.Keys) End Sub