PDA

View Full Version : [SOLVED] VBA macro for combining several cells into one



geomano
04-05-2017, 05:41 AM
Hi, I have a VBA macro for combining values from some columns into one. Now, what I would like to add is an option to combine those values into one cell with some spacing between lines, provided they have the same number in column A.

So that's my raw data:
18856
Now, I run my macro to combine the columns:
18857
And that's the final outcome, I would like to achieve:
18858
I am attaching my spreadsheet for your reference.

Thank you for your help.

mana
04-05-2017, 06:09 AM
Option Explicit

Sub test()
Dim r As Range
Dim s As String


For Each r In Cells(1).CurrentRegion.Columns("G:I").Rows
s = s & vbLf & Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(r)))
Next

MsgBox Mid(s, 2)

End Sub

mdmackillop
04-05-2017, 11:53 AM
If your data has a header row, you should show it in your example.

This assume an ordered list of differing numbers in Column A.
Using Mana's Join code but the loop seems clumsy here. Surely a better way.

Sub test()
Dim dic, d
Dim r As Range
Dim i As Long
Dim s As String


Rows(1).Insert
Cells(1, 1) = "TempHeader"
Set dic = CreateObject("Scripting.Dictionary")
Set r = Sheet1.Cells(1, 1).CurrentRegion.Columns(1).Cells

On Error Resume Next
For i = 2 To r.Cells.Count - 1
dic.Add CStr(r(i)), CStr(r(i))
Next
On Error GoTo 0

For Each d In dic
Columns(1).AutoFilter 1, d
For Each r In Cells(1).CurrentRegion.Columns("G:I").Rows
If r.Hidden = False Then
s = s & vbLf & Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(r)))
End If
Next
Columns(1).Find(d).Offset(, 10) = s
s = ""
Next d
Columns(1).AutoFilter
Rows(1).Delete
End Sub

geomano
04-05-2017, 10:00 PM
Thank you so much, that's precisely what I tried to create!

mike7952
04-07-2017, 06:08 PM
Another way with out a loop. I Posted solution here https://www.excelforum.com/excel-programming-vba-macros/1180405-vba-macro-for-combining-several-cells-into-one.html#post4623106


Sub Concat()
Dim txt As String
With Sheets(2)
With .Range("i1", .Cells(Rows.Count, "i").End(xlUp))
.Offset(, 1).Value = "=RC[-3] & "" "" & RC[-2] & "" "" & RC[-1]"
.Offset(, 1).Value = .Offset(, 1).Value
txt = Join(Application.Transpose(.Offset(, 1).Value), vbNewLine)
End With
.[k1] = txt
End With
End Sub