Getting unique values from the column

Question

I have this problem that I'm still not able to solve. I can probably use the Application.Transpose function but this will get all the unique values in the column. What I want to do is to get the unique value in the column if the other column values matches with the specific key.

If I use Application.Transpose, all the unique values in column C is taken. I only want to get the unique values in C if name of the student is a .And paste it in the column B of the newly added workbook. I've used this code to filter the unique values in B and paste it in the Column A of the newly added workbook.

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)

Any help is appreciated. Thanks!

Answer 1

I agree with Siddharth Rout that using Remove Duplicates is probably the way to go.

I tweaked your code a little to make it work.

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

---

We can also add a Dictionary to store unique values as keys to a Dictionary to stores the unique identifiers. This way we don;t have to iterate over the data twice.

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

NON VBA SOLUTION

1. Copy Data to a temp sheet.
2. Select Col A and Col B
3. Data | Remove Duplicates.
4. AutoFilter on Col A for the relevant name

VBA SOLUTION (Using Collection)

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