VBA Merge cells comma delimited

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
524
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Hi, i am trying to merge cells together comma delimited, I am almost there but need help, Can someone help with this please.

Code:
Sub MergeCommaDel()
'
    Dim objSelection, objCell As range, MyStr As String
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objSelection = Intersect(Selection, ActiveSheet.UsedRange)
    
    For Each objCell In objSelection
            MyStr = MyStr & VBA.Trim$(objCell) & ","
    Next
    
    With ActiveWindow
        .Selection(1, 1).NumberFormat = "@"
        .Selection(1, 1).Value = MyStr
    End With
    
End Sub

This is what I end up with so far
a,b,c,d,bcd

<tbody>
</tbody>

But What I would like to do is this

From This
abcd

<tbody>
</tbody>


To This

a,b,c,d

<tbody>
</tbody>
 

Some videos you may like

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

FormR

MrExcel MVP
Joined
Aug 18, 2011
Messages
6,430
Office Version
  1. 365
Platform
  1. Windows
Hi, maybe these subtle changes..

Rich (BB code):
Sub MergeCommaDel()


    Dim objSelection, objCell As Range, MyStr As String
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objSelection = Intersect(Selection, ActiveSheet.UsedRange)
    
    For Each objCell In objSelection
         MyStr = MyStr & "," & VBA.Trim$(objCell)
    Next
    
    With ActiveWindow
        .Selection.ClearContents
        .Selection(1, 1).NumberFormat = "@"
        .Selection(1, 1).Value = Mid(MyStr, 2)
    End With
    
End Sub
 

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
1,900
Code:
Sub CommaDelim()
Dim r As Long, c As Long
Dim iRct As Long, iCct As Long
Dim vWord

Range("A1").Select
iRct = ActiveSheet.UsedRange.Rows.Count
iCct = ActiveSheet.UsedRange.Columns.Count

For r = 1 To iRct
    For c = 1 To iCct
       If Cells(r, c).Value <> "" Then vWord = vWord & Cells(r, c).Value & ","
    Next
    
   Cells(r, c + 1).Value = Left(vWord, Len(vWord) - 1) 'remove last comma
   ActiveCell.Offset(1, 0).Select   'next row
   vWord = ""
Next
End Sub
 
Last edited:

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Perhaps:-
Code:
Dim rng As Range, Txt As String
Set rng = Selection '(A1:D1)
Txt = Join(Application.Transpose(Application.Transpose(rng)), ", ")
rng.ClearContents
rng(, 1) = Txt
 

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
524
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows

ADVERTISEMENT

These are perfect, Thank you all for your help, It's really appreciated
 

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
524
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Hi all, The codes posted does this for cells but how would i get the same results if columns are selected, any help would be appreciated

From This

abcde
fghij
klmno
pqrst

<tbody>
</tbody>


To This


a,b,c,d,e
f,g,h,i,j
k,l,m,n,o
p,q,r,s,t

<tbody>
</tbody>
 

FormR

MrExcel MVP
Joined
Aug 18, 2011
Messages
6,430
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hi, using your original code as the base - you could try.

Code:
Sub MergeCommaDel()


    Dim objSelection, objRow As Range, objCell As Range, MyStr As String
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objSelection = Intersect(Selection, ActiveSheet.UsedRange)
    
    For Each objRow In objSelection.Rows
        For Each objCell In objRow.Cells
             MyStr = MyStr & "," & VBA.Trim$(objCell)
        Next objCell
        objRow.ClearContents
        objRow.Cells(1, 1).NumberFormat = "@"
        objRow.Cells(1, 1) = Mid(MyStr, 2)
        MyStr = vbNullString
    Next objRow
    
End Sub
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG04Apr34
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, rng [COLOR="Navy"]As[/COLOR] Range, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
Set rng = Selection '[COLOR="Green"][B](A1:E1)[/B][/COLOR]
[COLOR="Navy"]If[/COLOR] rng.Count > 1 [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Selection.Columns(1).Cells
    Txt = Join(Application.Transpose(Application.Transpose(Dn.Resize(, rng.Columns.Count))), ", ")
    Dn.Resize(, rng.Columns.Count).Clear
    Dn.Value = Txt
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
524
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Thank you FormR and MickG I can use both of these, It's really appreciated
 

Watch MrExcel Video

Forum statistics

Threads
1,108,655
Messages
5,524,135
Members
409,562
Latest member
meeranaskar

This Week's Hot Topics

Top