Unique names and their related IDs

[YasserKhalil]

Hello everyone
I have in sheet 1 column C some duplicated names and their related IDs in column
In sheet Result I need to extract unique names in alphabetical order and extract their related items .. as illustrated in the attachment
Thanks advanced for help

 

[Marc L]

Hi !​

Sub Demo()
        VA = Sheet1.[B5].CurrentRegion.Value
        Application.ScreenUpdating = False
        Sheet2.Range("B5", Sheet2.Cells(Rows.Count, 3).End(xlUp)).Clear
With CreateObject("System.Collections.SortedList")
    For R& = 2 To UBound(VA)
        .Item(VA(R, 2)) = .Item(VA(R, 2)) & " " & VA(R, 1)
    Next
         R = 5
    For L% = 0 To .Count - 1
            Sheet2.Cells(R, 2).Value = .GetKey(L)
        For Each V In Split(LTrim(.GetByIndex(L)))
            R = R + 1
            Sheet2.Cells(R, 3).Value = V
        Next
            R = R + 2
    Next
        .Clear
End With
        Application.Goto Sheet2.Cells(1), True
        Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[YasserKhalil]

Thank you very very much Mr. MarcL
You are FANTASTIC as usual
Best Regards

 

[jindon]

Different method.

Sub test()
    Dim x, y, e, s, a, n As Long, i, ii, temp
    With Sheets("sheet1").[b5].CurrentRegion.Offset(1)
        ReDim a(1 To .Rows.Count * 3, 1 To 2)
        a(1, 1) = .Cells(0, 1): a(1, 2) = .Cells(0, 2): n = 1
        x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(2).Address & ",,,row(1:" & _
            .Rows.Count & "))," & .Columns(2).Address & ")=1," & .Columns(2).Address & ",char(2)))"), Chr(2), 0)
        If UBound(x) > 0 Then
            For i = 0 To UBound(x) - 1
                For ii = i + 1 To UBound(x)
                    If x(i) > x(ii) Then
                        temp = x(i): x(i) = x(ii): x(ii) = temp
                    End If
            Next ii, i
        End If
        For Each e In x
            n = n + 1: a(n, 1) = e
            For Each s In Filter(.Parent.Evaluate("transpose(if(" & .Columns(2).Address & _
                "=""" & e & """," & .Columns(1).Address & ",char(2)))"), Chr(2), 0)
                n = n + 1: a(n, 2) = s
            Next
            n = n + 1
        Next
    End With
    Sheets("result").[b4].Resize(n - 1, 2).Value = a
End Sub

 

[mohadin]

Hi !​

Sub Demo()
        VA = Sheet1.[B5].CurrentRegion.Value
        Application.ScreenUpdating = False
        Sheet2.Range("B5", Sheet2.Cells(Rows.Count, 3).End(xlUp)).Clear
With CreateObject("System.Collections.SortedList")
    For R& = 2 To UBound(VA)
        .Item(VA(R, 2)) = .Item(VA(R, 2)) & " " & VA(R, 1)
    Next
         R = 5
    For L% = 0 To .Count - 1
            Sheet2.Cells(R, 2).Value = .GetKey(L)
        For Each V In Split(LTrim(.GetByIndex(L)))
            R = R + 1
            Sheet2.Cells(R, 3).Value = V
        Next
            R = R + 2
    Next
        .Clear
End With
        Application.Goto Sheet2.Cells(1), True
        Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

Hi Sir,
would you kindly please explain the peace in red color
Thank you

 

[Marc L]

I see nothing in red !

But all is explained within VBA help or via MSDN website …
​

 

[shrivallabha]

You can also Pivot Table to do this also.

 

[YasserKhalil]

Thanks a lot Mr. Jindon for this great solution .. It is difficult for me to grasb but I will try to study it
Thanks Mr. Shrivallabha for reply but in fact I am not expert at pivot tables at all