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

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Animal[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Elephant[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Dragon[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Dog[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Cat[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Mourse[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Bird[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Hawk[/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD]Lion[/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD]Tiger[/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD]Bear[/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD]Panda[/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD]Snake[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]Cobra[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]Lion[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]Dragon[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]Mouse[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]Bear[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]Hawk[/TD]
[/TR]
</tbody>[/TABLE]



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.
[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Animal[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Elephant, Dragon, Dog, Cat, Mouse, Bird, Hawk[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD]Lion, Tiger, Bear[/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD]Panda, Snake[/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]Cobra, Lion Dragon, Mouse, Bear, Hawk[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]



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?

[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[/TR]
[TR]
[TD]Name[/TD]
[TD]Animal[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]Dragon, Dog, Cat, Mouse, Bird, Hawk[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD]Tiger, Bear[/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD]Snake[/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]Lion Dragon, Mouse, Bear, Hawk[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor




Thank you!

[/TD]
[/TR]
</tbody>[/TABLE]

 

[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!

[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Animal[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]

• Elephant
• Dragon
• Dog
• Cat
• Mouse
• Bird
• Hawk

[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD]

• Lion
• Tiger
• Bear

[/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]April[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD]

• Panda
• Snake

[/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD]

• Cobra
• Lion
• Dragon
• Mouse
• Bear
• Hawk

[/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Thor[/TD]
[/TR]
</tbody>[/TABLE]

 

[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