VBA Merge cells comma delimited

[decadence]

Hi, i am trying to merge cells together comma delimited, I am almost there but need help, Can someone help with this please.

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
[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]a,b,c,d,[/TD]
[TD]b[/TD]
[TD]c[/TD]
[TD]d[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

But What I would like to do is this

From This
[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]a[/TD]
[TD]b[/TD]
[TD]c[/TD]
[TD]d[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


To This

[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]a,b,c,d[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[FormR]

Hi, maybe these subtle changes..

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]

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

 

[MickG]

Perhaps:-

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]

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

 

[decadence]

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

[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]a[/TD]
[TD]b[/TD]
[TD]c[/TD]
[TD]d[/TD]
[TD]e[/TD]
[/TR]
[TR]
[TD]f[/TD]
[TD]g[/TD]
[TD]h[/TD]
[TD]i[/TD]
[TD]j[/TD]
[/TR]
[TR]
[TD]k[/TD]
[TD]l[/TD]
[TD]m[/TD]
[TD]n[/TD]
[TD]o[/TD]
[/TR]
[TR]
[TD]p[/TD]
[TD]q[/TD]
[TD]r[/TD]
[TD]s[/TD]
[TD]t[/TD]
[/TR]
</tbody>[/TABLE]


To This


[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]a,b,c,d,e[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]f,g,h,i,j[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]k,l,m,n,o[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]p,q,r,s,t[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[FormR]

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

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]

Try this:-

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

Thank you FormR and MickG I can use both of these, It's really appreciated

 

[MickG]

You're welcome