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

a,b,c,d,	b	c	d

<tbody>
</tbody>

But What I would like to do is this

From This

a	b	c	d

<tbody>
</tbody>

To This

a,b,c,d

<tbody>
</tbody>

 

[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

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

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

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