VBA Merge Columns comma delimited while keeping formats

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
525
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
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:
[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]This[/TD]
[TD]is [/TD]
[TD]not [/TD]
[TD]a[/TD]
[TD]Test[/TD]
[/TR]
[TR]
[TD]This[/TD]
[TD]is [/TD]
[TD]a[/TD]
[TD]Test[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Number[/TD]
[TD]100.123[/TD]
[TD]90[/TD]
[TD]is[/TD]
[TD]here[/TD]
[/TR]
[TR]
[TD]Something[/TD]
[TD]else[/TD]
[TD]or[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Nothing[/TD]
[TD]has[/TD]
[TD]been [/TD]
[TD]found[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

To This:
[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]This,is,not,a,Test[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]This,is,a,Test[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Number,100.123,90,is,here[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Something,else,or[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Nothing,has,been,found[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
What you have shown is just joining - nothing about format here. So for instance:
Code:
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
 
Upvote 0
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
[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]Number,2.340,150,is,here[/TD]
[/TR]
</tbody>[/TABLE]

Or This
[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]Number,12.300,360,is,here[/TD]
[/TR]
</tbody>[/TABLE]


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

[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]Number,2.34,150,is,here[/TD]
[/TR]
</tbody>[/TABLE]

Or This

[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TD]Number,12.3,360,is,here[/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:
Upvote 0
decadence,

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

Code:
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
 
Upvote 0
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.

Code:
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
ABCDE
1ThisisnotaTest
2ThisisaTest
3Number100.12390ishere
4Somethingelseor
5Nothinghasbeenfound
6Number2.3405022.000
Combine



After:
Excel Workbook
AB
1This,is,not,a,Test
2This,is,a,Test
3Number,100.123,90,is,here
4Something,else,or
5Nothing,has,been,found
6Number,2.340,50,22.000
Combine
 
Last edited:
Upvote 0
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.
 
Last edited:
Upvote 0
decadence,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.
 
Upvote 0
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":
Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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
Back
Top