VBA Loop to combining cells in a column into a single cell

[Magoosball]

I am trying to add onto a current VBA script to do the following:

The name itself and the number of names will be different each time the script is ran.

Before

Name	Animal
Mike	Elephant
Mike	Dragon
Mike	Dog
Mike	Cat
Mike	Mourse
Mike	Bird
Mike	Hawk
April	Lion
April	Tiger
April	Bear
James	Panda
James	Snake
Thor	Cobra
Thor	Lion
Thor	Dragon
Thor	Mouse
Thor	Bear
Thor	Hawk

<tbody>
</tbody>

After: Column 2 should only have 4 merged cells going down in this example. Each 1 with Mike should be merged, each with April should be merged, Each with James merged and each with Thor merged. Wasn't sure how to add that in this table.

Name	Animal
Mike	Elephant, Dragon, Dog, Cat, Mouse, Bird, Hawk
Mike
Mike
Mike
Mike
Mike
Mike
April	Lion, Tiger, Bear
April
April
James	Panda, Snake
James
Thor	Cobra, Lion Dragon, Mouse, Bear, Hawk
Thor
Thor
Thor
Thor
Thor

<tbody>
</tbody>

Thank you in advance!!

 

[MickG]

Generally speaking VBA and Merged Cells do not go well together, but try this:-

[COLOR="Navy"]Sub[/COLOR] MG04Jan41
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
.Add Dn.Value, Array(Dn, Dn.Value)
[COLOR="Navy"]Else[/COLOR]
    Q = .Item(Dn.Value)
        [COLOR="Navy"]Set[/COLOR] Q(0) = Union(Q(0), Dn)
        Q(1) = Q(1) & ", " & Dn.Offset(, 1).Value
    .Item(Dn.Value) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Application.DisplayAlerts = False
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    .Item(K)(0)(1).Offset(, 1) = .Item(K)(1)
    .Item(K)(0).Offset(, 1).Merge
    .Item(K)(0)(1).Offset(, 1).VerticalAlignment = xlTop
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Magoosball]

Thank you for getting this posted so quickly and sorry for the delayed response here.

This worked perfectly! Really appreciate the help

 

[MickG]

You're welcome

 

[Magoosball]

After using this multiple times there is a problem with it. This seems to delete the first cells worth of text.
After running your script with the previous example it looks like this. As you can see Elephant was deleted from mike, Lion was deleted from April, Panda was deleted from James and Cobra was deleted from Thor. Any idea how I can fix this?

Name	Animal
Mike	Dragon, Dog, Cat, Mouse, Bird, Hawk
Mike
Mike
Mike
Mike
Mike
Mike
April	Tiger, Bear
April
April
James	Snake
James
Thor	Lion Dragon, Mouse, Bear, Hawk
Thor
Thor
Thor
Thor
Thor Thank you!

<tbody>
</tbody>

 

[MickG]

Sorry.
Change this line :-

.Add Dn.Value, Array(Dn, Dn.Value)

To this line:-

.Add Dn.Value, Array(Dn, Dn.offset(,1).Value)

 

[Magoosball]

Hi Mick,

The above is still working great! I use it every day and it has been a great help!
What if instead of separating by comma I wanted to put each as a separate bullet point? Is this possible? Below is an example. Thank you in advance!

Name	Animal
Mike	Elephant Dragon Dog Cat Mouse Bird Hawk
Mike
Mike
Mike
Mike
Mike
Mike
April	Lion Tiger Bear
April
April
James	Panda Snake
James
Thor	Cobra Lion Dragon Mouse Bear Hawk
Thor
Thor
Thor
Thor
Thor

<tbody>
</tbody>

 

[Peter_SSs]

Here is a different approach that also incorporates your latest request. I hope it does what you want.

Sub CombineValues()
  Dim i As Long, k As Long, fr As Long
  Dim s As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  fr = 2:  k = 1
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    s = s & Chr(10) & "• " & Cells(i, 2).Value
    If Cells(i, 1).Value = Cells(i + 1, 1).Value Then
      k = k + 1
    Else
      With Cells(fr, 2)
        .Resize(k).Merge
        .Value = Mid(s, 2)
      End With
      k = 1:  fr = i + 1: s = vbNullString
    End If
  Next i
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub