VBA Merge Columns comma delimited while keeping formats

[decadence]

Hi, Is it possible to combine columns into one comma delimited column while keeping the formats from the cells in the columns that are to be combined then delete the columns used to combine with

Example:

From This:

This	is	not	a	Test
This	is	a	Test
Number	100.123	90	is	here
Something	else	or
Nothing	has	been	found

<tbody>
</tbody>

To This:

This,is,not,a,Test
This,is,a,Test
Number,100.123,90,is,here
Something,else,or
Nothing,has,been,found

<tbody>
</tbody>

 

[Kaper]

What you have shown is just joining - nothing about format here. So for instance:

Sub test()
Dim i&, j&
For i = 1 To 5
  For j = 2 To 5
    Cells(i, 1) = Cells(i, 1) & IIf(Cells(i, j) <> "", "," & Cells(i, j), "")
Next j, i
Range("B1:E5").ClearContents
End Sub

shall do

 

[decadence]

Hi Kaper, This is great but there is number formatting on some cells in a column which is to 3 decimal places (For Example: 100.123 or 2.340 or 12.300) where there are some cells that don't have number formatting (For Example: 90 or 150 or 360)

For Example:

What I would like is this

Number,2.340,150,is,here

<tbody>
</tbody>

Or This

Number,12.300,360,is,here

<tbody>
</tbody>

But what I end up with is this because of the Number Formatting is not in the first column and if it was then 150 and 360 would become 150.000 and 360.000

Number,2.34,150,is,here

<tbody>
</tbody>

Or This

Number,12.3,360,is,here

<tbody>
</tbody>

 

[hiker95]

decadence,

Be right back.

 

[hiker95]

decadence,

Please try the following macro in a copy of your workbook, the active worksheet.

Sub MergeColumns()
' hiker95, 03/09/2018, ME1046785
Application.ScreenUpdating = False
Dim a As Variant, r As Long, c As Long
Dim o As Variant, j As Long, t As String
With ActiveSheet
  .Cells(1, 1).CurrentRegion.NumberFormat = "@"
  a = .Cells(1, 1).CurrentRegion
  ReDim o(1 To UBound(a, 1))
  For r = LBound(a) To UBound(a)
    t = ""
    For c = 1 To UBound(a, 2)
      If Not a(r, c) = vbEmpty Then
        t = t & a(r, c) & ","
      End If
    Next c
    t = Left(t, Len(t) - 1)
    j = j + 1
    o(j) = t
  Next r
  .Cells(1, 1).CurrentRegion.ClearContents
  .Cells(1, 1).Resize(UBound(o)) = Application.Transpose(o)
  .UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

This should retain those number formats - provided the original columns are wide enough to display them. If your data is very large and speed becomes a problem, post back with details as speed could be improved a bit, depending on what proportion of cells contain such formatted numbers.

Sub CombineColumns1()
  Dim rw As Range, c As Range
  Dim RwStr As String
  
  Application.ScreenUpdating = False
  For Each rw In Range("A1").CurrentRegion.Rows
    RwStr = ""
    For Each c In rw.Cells
      If Len(c.Text) > 0 Then RwStr = RwStr & "," & c.Text
    Next c
    rw.Cells(1).Value = Mid(RwStr, 2)
  Next rw
  Range("A1").CurrentRegion.Offset(, 1).EntireColumn.Delete
  Columns(1).AutoFit
  Application.ScreenUpdating = True
End Sub

Before:

Excel Workbook
	A	B	C	D	E
1	This	is	not	a	Test
2	This	is	a	Test
3	Number	100.123	90	is	here
4	Something	else	or
5	Nothing	has	been	found
6	Number	2.340	50	22.000
Combine

After:

Excel Workbook
	A	B
1	This,is,not,a,Test
2	This,is,a,Test
3	Number,100.123,90,is,here
4	Something,else,or
5	Nothing,has,been,found
6	Number,2.340,50,22.000
Combine

 

[decadence]

Hi Hiker95, When the number format is changed to @ the 3 decimal places are changed as well. However Peter_SSs has solved it.

Hi Peter_SSs This is Perfect

Thank you Kaper, Hiker95, Peter_SSs for helping with this.

 

[hiker95]

decadence,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.

 

[Peter_SSs]

Hi Peter_SSs This is Perfect

Thank you Kaper, Hiker95, Peter_SSs for helping with this.

You are welcome. Glad it worked for you.

 

[Kaper]

Good to see it solved.
In my code just changing default returned property of cells (Value) to Text would do:
Of course then it's needed to properlu setup a range for the code to wotk, but the procedure is just a "demonstrator":

Sub test()
Dim i&, j&
For i = 1 To 5
  For j = 2 To 5
    Cells(i, 1) = Cells(i, 1).Text & IIf(Cells(i, j) <> "", "," & Cells(i, j).Text, "")
Next j, i
Range("B1:E5").ClearContents
End Sub