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

Magoosball

Board Regular
Joined
Jun 4, 2017
Messages
55
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

NameAnimal
MikeElephant
MikeDragon
MikeDog
MikeCat
MikeMourse
MikeBird
MikeHawk
AprilLion
AprilTiger
AprilBear
JamesPanda
JamesSnake
ThorCobra
ThorLion
ThorDragon
ThorMouse
ThorBear
ThorHawk

<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.
NameAnimal
MikeElephant, Dragon, Dog, Cat, Mouse, Bird, Hawk
Mike
Mike
Mike
Mike
Mike
Mike
AprilLion, Tiger, Bear
April
April
JamesPanda, Snake
James
ThorCobra, Lion Dragon, Mouse, Bear, Hawk
Thor
Thor
Thor
Thor
Thor

<tbody>
</tbody>



Thank you in advance!!

 

Some videos you may like

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Generally speaking VBA and Merged Cells do not go well together, but try this:-
Code:
[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

Board Regular
Joined
Jun 4, 2017
Messages
55
Thank you for getting this posted so quickly and sorry for the delayed response here.

This worked perfectly! Really appreciate the help
 

Magoosball

Board Regular
Joined
Jun 4, 2017
Messages
55

ADVERTISEMENT

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?

NameAnimal
MikeDragon, Dog, Cat, Mouse, Bird, Hawk
Mike
Mike
Mike
Mike
Mike
Mike
AprilTiger, Bear
April
April
JamesSnake
James
ThorLion Dragon, Mouse, Bear, Hawk
Thor
Thor
Thor
Thor
Thor




Thank you!


<tbody>
</tbody>
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Sorry.
Change this line :-
Code:
.Add Dn.Value, Array(Dn, Dn.Value)

To this line:-
Code:
.Add Dn.Value, Array(Dn, Dn.offset(,1).Value)
 

Magoosball

Board Regular
Joined
Jun 4, 2017
Messages
55
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!

NameAnimal
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,400
Office Version
  1. 365
Platform
  1. Windows
Here is a different approach that also incorporates your latest request. I hope it does what you want.
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,734
Messages
5,626,576
Members
416,192
Latest member
steinach

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top