Macro to combine all First Names from duplicate Last Name

[freerskys]

Hello Friends, I need help with a project I’m working on, please.
There are 4000 Rows, consisting of, Cell A = First Name , Cell B = Last Name.
Last Name will have Doubles, if so, all the first names that are associated with the double last names, would all go next to the first last name , all in one cell.

Example:

Tom King
Lucy King
Jane King

Result: Tom, Lucy, Jane King.

Put this on the same row next to the King (Cell).
Do this, till the end of the 4000 rows.
Using Excel 2010.
Thank you.

 

[Zot]

Like this? No more sheet2?

Sub GroupName()

Dim n As Long
Dim key As Variant
Dim cell As Range, rngData As Range
Dim dName As Object
Dim ws1 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set dName = CreateObject("Scripting.Dictionary")

Set rngData = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngData
    If Not dName.Exists(cell.Offset(0, 1).Value) Then
        dName.Add cell.Offset(0, 1).Value, cell.Value
    Else
        dName(cell.Offset(0, 1).Value) = dName(cell.Offset(0, 1).Value) & ", " & cell.Value
    End If
Next

n = 1
For Each key In dName
    n = n + 1
    ws1.Range("D" & n) = dName(key) & " " & key
Next

End Sub

 

[freerskys]

Like this? No more sheet2?

Sub GroupName()

Dim n As Long
Dim key As Variant
Dim cell As Range, rngData As Range
Dim dName As Object
Dim ws1 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set dName = CreateObject("Scripting.Dictionary")

Set rngData = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngData
    If Not dName.Exists(cell.Offset(0, 1).Value) Then
        dName.Add cell.Offset(0, 1).Value, cell.Value
    Else
        dName(cell.Offset(0, 1).Value) = dName(cell.Offset(0, 1).Value) & ", " & cell.Value
    End If
Next

n = 1
For Each key In dName
    n = n + 1
    ws1.Range("D" & n) = dName(key) & " " & key
Next

End Sub

Sheet 2 is not needed,
It's not spacing correctly in column D, it's putting it all together.

 

[bebo021999]

Like this?

Option Explicit
Sub GroupName()
Dim arr(1 To 1000000, 1 To 1)
Dim spl, Lr&, k&, cell As Range, key, key1, st As String
Dim dic As Object, dic1 As Object
Set dic = CreateObject("Scripting.dictionary")
Set dic1 = CreateObject("Scripting.dictionary")
Lr = Cells(Rows.Count, "A").End(xlUp).Row
    ' create unique full name list
    For Each cell In Range("A2:A" & Lr)
        If Not dic.exists(cell.Value) Then
            dic.Add cell.Value, ""
        End If
    Next
    'creat unique last name list
    For Each key1 In dic.keys
        spl = Split(key1, " ")
        If Not dic1.exists(spl(UBound(spl))) Then
            dic1.Add spl(UBound(spl)), ""
        End If
    Next
    'loop through last name then combine first name
    For Each key1 In dic1.keys
        For Each key In dic.keys
            spl = Split(key, " ")
            If spl(UBound(spl)) Like key1 Then
                st = st & "," & Left(key, Len(key) - Len(spl(UBound(spl))))
            End If
        Next
        k = k + 1
        arr(k, 1) = Right(st, Len(st) - 1) & key1
        st = ""
    Next
    k = 0
    'write down to column D
    For Each cell In Range("A2:A" & Lr)
        spl = Split(cell, " ")
        If Not cell.Offset(-1, 0) Like "*" & spl(UBound(spl)) Then
        k = k + 1
        cell.Offset(0, 3).Value = arr(k, 1)
        End If
    Next
End Sub

 

[Zot]

If you meant something like @bebo021999 shown, then the modified code would be

Sub GroupName1()

Dim LName As String
Dim cell As Range, rngData As Range
Dim dName As Object
Dim ws As Worksheet

Application.ScreenUpdating = False

Set ws = ActiveWorkbook.Sheets("Sheet1")
Set dName = CreateObject("Scripting.Dictionary")

Set rngData = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngData
    If Not dName.Exists(cell.Offset(0, 1).Value) Then
        dName.Add cell.Offset(0, 1).Value, cell.Value
    Else
        dName(cell.Offset(0, 1).Value) = dName(cell.Offset(0, 1).Value) & ", " & cell.Value
    End If
    cell = cell & " " & cell.Offset(0, 1)
    cell.Offset(0, 1) = ""
Next

For Each cell In rngData
    LName = Split(cell)(1)
    If dName.Exists(LName) Then
        ws.Range("D" & cell.Row) = dName(LName) & " " & LName
        dName.Remove LName
    End If
Next

End Sub

 

[freerskys]

This is exactly it, both Zot and bebo021999 got it right.
Thank you, very much.