Question

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

如果我使用Application.Transpose，则会获取C列中的所有唯一值。如果学生的姓名为a，我只想在C中获取唯一值。并将其粘贴到新添加的工作簿的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

我同意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

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

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

Answer 2

非VBA解决方案

将数据复制到临时表。
选择Col A和Col B
数据|删除重复项。
Col A上的AutoFilter以获取相关名称

VBA解决方案（使用收藏）

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

从列中获取唯一值

2 个答案: