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]

This will create list in column D

Sub GroupName()

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
Next

Set rngData = rngData.Offset(0, 1)
For Each cell In rngData
    If dName.Exists(cell.Value) Then
        ws.Range("D" & cell.Row) = dName(cell.Value) & " " & cell.Value
        dName.Remove cell.Value
    End If
Next

End Sub

 

[freerskys]

This will create list in column D

Sub GroupName()

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
Next

Set rngData = rngData.Offset(0, 1)
For Each cell In rngData
    If dName.Exists(cell.Value) Then
        ws.Range("D" & cell.Row) = dName(cell.Value) & " " & cell.Value
        dName.Remove cell.Value
    End If
Next

End Sub

Wow, you are incredible, fast.
Thank you.

 

[freerskys]

Hey Zot, could you please add a way to delete all the doubles on the left side, keeping the one, with all the first names.
Thanks.

 

[Zot]

Hey Zot, could you please add a way to delete all the doubles on the left side, keeping the one, with all the first names.
Thanks.

I could not understand what you meant.

 

[Zot]

Do you want to just keep the result on the column D and delete all data in column A and B?

 

[Zot]

I think the best way is to create a list in another sheet, leaving the original data as they are for reference just in case. Can delete the sheet after that

This is create list in Sheet2 starting from range A1

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, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")
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 = 0
For Each key In dName
    n = n + 1
    ws2.Range("A" & n) = dName(key) & " " & key
Next
    
End Sub

 

[freerskys]

This is also good, I could use that, I still need to keep the First double, Last Name in sheet 1.
Example:

Tom King Tom King
Lucy King Would look like--->
Jane King

Result: Tom, Lucy, Jane King. Result: Tom, Lucy, Jane King.

Keep the first , delete the other two.

 

[Zot]

This is also good, I could use that, I still need to keep the First double, Last Name in sheet 1.
Example:

Tom King Tom King
Lucy King Would look like--->
Jane King

Result: Tom, Lucy, Jane King. Result: Tom, Lucy, Jane King.

Keep the first , delete the other two.

Not sure I clearly understood your request. This will create:
1) List first occurrence of the shared Last Name in column D
2) List of all combined name in 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, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")
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
        cell.Offset(0, 3) = cell & " " & cell.Offset(0, 1)
    Else
        dName(cell.Offset(0, 1).Value) = dName(cell.Offset(0, 1).Value) & ", " & cell.Value
    End If
Next

n = 0
For Each key In dName
    n = n + 1
    ws2.Range("A" & n) = dName(key) & " " & key
Next

End Sub

 

[freerskys]

Not sure I clearly understood your request. This will create:
1) List first occurrence of the shared Last Name in column D
2) List of all combined name in 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, ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")
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
        cell.Offset(0, 3) = cell & " " & cell.Offset(0, 1)
    Else
        dName(cell.Offset(0, 1).Value) = dName(cell.Offset(0, 1).Value) & ", " & cell.Value
    End If
Next

n = 0
For Each key In dName
    n = n + 1
    ws2.Range("A" & n) = dName(key) & " " & key
Next

End Sub

I'm so sorry for not explaining myself better.
Would you be kind enough(third time the charm) to make column D look like, what's on Sheet 2.
The important part, I need the exact spacing that column D has now.