Combining/Merging multiple columns of row (loop on rows) with delimiter

P

pratnimk

New Member
Joined
Feb 8, 2017
Messages
10
Hello All

I was looking to create a macro that would combine all column values in one single column using a delimiter (comma)
I have variable column numbers per row

[TABLE="class: grid, width: 100, align: left"]
<tbody>[TR]
[TD]A[/TD]
[TD]D[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD]E[/TD]
[TD]F[/TD]
[/TR]
</tbody>[/TABLE]






Result:

[TABLE="class: grid, width: 100, align: left"]
<tbody>[TR]
[TD]A, D[/TD]
[/TR]
[TR]
[TD]B[/TD]
[/TR]
[TR]
[TD]C, E, F[/TD]
[/TR]
</tbody>[/TABLE]






Please help
Apologies if this has already been asked before

Thanks in advance
P
 
Sort by date Sort by votes
Welcome to the board. The following code assumes your data starts in cell A1 and that the first row defines the last used column and outputs the results next to the last column:
Code: 
Sub Macro1()


    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    x = Cells(Rows.Count, 1).End(xlUp).row
    y = Cells.find(what:="*", after:=Cells(1, 1), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column + 1
   
    arr = Cells(1, 1).Resize(x, y).Value
        
    For x = LBound(arr, 1) To UBound(arr, 1)
        For y = UBound(arr, 2) - 1 To LBound(arr, 2) Step -1
            If LenB(arr(x, y)) > 0 Then arr(x, UBound(arr, 2)) = arr(x, y) & ", " & arr(x, UBound(arr, 2))
        Next y
        arr(x, UBound(arr, 2)) = Left$(arr(x, UBound(arr, 2)), Len(arr(x, UBound(arr, 2))) - 2)
    Next x
    
    Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Erase arr
    
End Sub
 
Last edited:
Upvote 0
Hello JackDanIce

Thank you for your prompt reply

The macro you've written does solve my issue :)

However, my columns start from B
and I was wondering if it is possible to get the results in column A
as I will be processing it further

Thanks
P

JackDanIce said:
Welcome to the board. The following code assumes your data starts in cell A1 and that the first row defines the last used column and outputs the results next to the last column:
Code: 
Sub Macro1()


    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    x = Cells(Rows.Count, 1).End(xlUp).row
    y = Cells.find(what:="*", after:=Cells(1, 1), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column + 1
   
    arr = Cells(1, 1).Resize(x, y).Value
        
    For x = LBound(arr, 1) To UBound(arr, 1)
        For y = UBound(arr, 2) - 1 To LBound(arr, 2) Step -1
            If LenB(arr(x, y)) > 0 Then arr(x, UBound(arr, 2)) = arr(x, y) & ", " & arr(x, UBound(arr, 2))
        Next y
        arr(x, UBound(arr, 2)) = Left$(arr(x, UBound(arr, 2)), Len(arr(x, UBound(arr, 2))) - 2)
    Next x
    
    Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Erase arr
    
End Sub
Click to expand...
 
Upvote 0
Try:
Code: 
Sub Macro2()

    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    x = Cells(Rows.Count, 2).End(xlUp).row
    y = Cells.find(what:="*", after:=Cells(1, 1), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column + 1
   
    arr = Cells(1, 1).Resize(x, y).Value
        
    For x = LBound(arr, 1) To UBound(arr, 1)
        For y = UBound(arr, 2) To LBound(arr, 2) + 1 Step -1
            If LenB(arr(x, y)) > 0 Then arr(x, LBound(arr, 2)) = arr(x, y) & ", " & arr(x, LBound(arr, 2))
        Next y
        arr(x, LBound(arr, 2)) = Left$(arr(x, LBound(arr, 2)), Len(arr(x, LBound(arr, 2))) - 2)
    Next x
    
    Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Erase arr
    
End Sub
 
Last edited:
Upvote 0
pratnimk,

Welcome to the MrExcel forum.

Here is another macro solution for you to consider, that uses two arrays in memory, and, will adjust to the number of raw data rows, and, columns.

Sample raw data in the active worksheet:


Excel 2007
ABCDE
1AD
2B
3CEF
4
Sheet1


And, after the macro:


Excel 2007
ABCDE
1A, DAD
2BB
3C, E, FCEF
4
Sheet1


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code: 
Sub MergeData()
' hiker95, 02/08/2017, ME990036
Dim a As Variant, i As Long, c As Long
Dim o As Variant, lr As Long, lc As Long
Application.ScreenUpdating = False
With ActiveSheet
  lr = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  a = .Range(.Cells(1, 2), .Cells(lr, lc))
  ReDim o(1 To UBound(a, 1), 1 To 1)
  For i = LBound(a, 1) To UBound(a, 1)
    o(i, 1) = a(i, 1)
    For c = LBound(a, 2) + 1 To UBound(a, 2)
      If Not a(i, c) = vbEmpty Then
        o(i, 1) = o(i, 1) & ", " & a(i, c)
      End If
    Next c
  Next i
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).AutoFit
End With
Application.ScreenUpdating = True
End Sub

Then run the MergeData macro.
 
Upvote 0
Hello JackDanIce

I've tried your updated macro
Its working just fine and solves my issue

Thanks a lot

Cheers
P

JackDanIce said:
Try:
Code: 
Sub Macro2()

    Dim arr()   As Variant
    Dim x       As Long
    Dim y       As Long
    
    x = Cells(Rows.Count, 2).End(xlUp).row
    y = Cells.find(what:="*", after:=Cells(1, 1), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column + 1
   
    arr = Cells(1, 1).Resize(x, y).Value
        
    For x = LBound(arr, 1) To UBound(arr, 1)
        For y = UBound(arr, 2) To LBound(arr, 2) + 1 Step -1
            If LenB(arr(x, y)) > 0 Then arr(x, LBound(arr, 2)) = arr(x, y) & ", " & arr(x, LBound(arr, 2))
        Next y
        arr(x, LBound(arr, 2)) = Left$(arr(x, LBound(arr, 2)), Len(arr(x, LBound(arr, 2))) - 2)
    Next x
    
    Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Erase arr
    
End Sub
Click to expand...
 
Upvote 0
Hello hiker95

I've tried your macro
and it solves my issue as well

Thank you for your help

Cheers
P

hiker95 said:
pratnimk,

Welcome to the MrExcel forum.

Here is another macro solution for you to consider, that uses two arrays in memory, and, will adjust to the number of raw data rows, and, columns.

Sample raw data in the active worksheet:

Excel 2007
ABCDE

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="bgcolor: #FFFFFF"]A[/TD]
[TD="bgcolor: #FFFFFF"]D[/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="bgcolor: #FFFFFF"]B[/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="bgcolor: #FFFFFF"]C[/TD]
[TD="bgcolor: #FFFFFF"]E[/TD]
[TD="bgcolor: #FFFFFF"]F[/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

</tbody>
Sheet1​



And, after the macro:

Excel 2007
ABCDE

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]
[TD="bgcolor: #FFFFFF"]A, D[/TD]
[TD="bgcolor: #FFFFFF"]A[/TD]
[TD="bgcolor: #FFFFFF"]D[/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]
[TD="bgcolor: #FFFFFF"]B[/TD]
[TD="bgcolor: #FFFFFF"]B[/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="bgcolor: #FFFFFF, align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]
[TD="bgcolor: #FFFFFF"]C, E, F[/TD]
[TD="bgcolor: #FFFFFF"]C[/TD]
[TD="bgcolor: #FFFFFF"]E[/TD]
[TD="bgcolor: #FFFFFF"]F[/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

</tbody>
Sheet1​



Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code: 
Sub MergeData()
' hiker95, 02/08/2017, ME990036
Dim a As Variant, i As Long, c As Long
Dim o As Variant, lr As Long, lc As Long
Application.ScreenUpdating = False
With ActiveSheet
  lr = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  a = .Range(.Cells(1, 2), .Cells(lr, lc))
  ReDim o(1 To UBound(a, 1), 1 To 1)
  For i = LBound(a, 1) To UBound(a, 1)
    o(i, 1) = a(i, 1)
    For c = LBound(a, 2) + 1 To UBound(a, 2)
      If Not a(i, c) = vbEmpty Then
        o(i, 1) = o(i, 1) & ", " & a(i, c)
      End If
    Next c
  Next i
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).AutoFit
End With
Application.ScreenUpdating = True
End Sub

Then run the MergeData macro.
Click to expand...
 
Upvote 0
pratnimk,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Need to transpose data from column to row but in different way
Replies
6
Views
206
Fluff
Fluff
A
  • Question Question
Cancel merged columns and arrange structure across files in the folders
2 3
Replies
20
Views
384
Joe4
Joe4
E
  • Solved
All Unique Combinations from 5 Columns of Data + Customizations - Excel 365
Replies
6
Views
349
Excel Jason
E
N
  • Solved
How to Merge Multiple VBA scripts as one?
Replies
7
Views
438
StephenCrump
S
R
  • Question Question
VBA Inserting rows based on Column criteria
Replies
4
Views
364
myall_blues
myall_blues

Share this page

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