0

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. enter image description here

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!

1
  • 1
    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 Commented Jul 29, 2016 at 5:23

2 Answers 2

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
Sign up to request clarification or add additional context in comments.

Comments

2

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.

enter image description here

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

5 Comments

Can you please explain what does that numbers stand for? hehe.. thanks .
I copied a Option Base 1 two dimensional array from the range. Then I iterate over them just as you would a range of cells. var(1, 1) is equivalent to Cells(1,1).
@ThomasInzina What does var(x, 2) mean? Thanks
x if the current index of the var array an 1 is the first dimension of an Option Based 1 array (an array that first element starts at 1 instead of 0). Using the screenshot as a reference, if x = 1 then var(x, 1) will equal name "Name" and var(x, 2) will equal "Section".
@ThomasInzina Got it! What if I have to loop it and get the sections of b and so on?

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.