Join multiple rows data into one row

[Jeremy]

Hi, I need help to create a macro that will combine multiple rows data into
one rows using user selected separator, could be ',', '/', or '|'. The macro
will combine multiple columns data into one column.

My form has 2 refedit controls, 1 to select the range to join, 1 to select
the cell to copy the final results.

For example:
Michael
Jesse
Jeremy
Lindsay

becomes Michael | Jesse | Jeremy | Lindsay

Thanks.

Jeremy

 

[Jacob Skaria]

Try the below macro. Adjust the range as required

Sub MacroTest()

Dim strData As String
Dim varRange As Range
Dim varTemp As Range

Set varRange = Range("A1:A10")

For Each varTemp In varRange
If varTemp.Text <> "" Then
strData = strData & "," & varTemp.Text
End If
Next
MsgBox Mid(strData, 2)

End Sub

 

[Albert]

I have similar issue but more complecated.

Here is an example of wha I am tying to do:

A1 = 123b
A2 = asf
A3 = afasf
A4 = afasf
A5 = awry
A6 = net
A7 =
A8 = tegndg
A9 = dgndg
A10 = dgndg
A11 = sd
A12 = sdb
A13 = fbsf
A14 = sffsbsf
A15 =
A16 = sfbsf
A17 = sfbsf
A18 = bwr
A19 = sfbsf
A20 = sfbsf
A21 =
A22 = sfbsf
A23 = sfbsfb
A24 = sfbf
A25 = sfb
A26 = sfb
A27 = sf
A28 =


I need all text in one row for text located between an empty cells, so A1 to
A6 will combined, A8 to A14 will combined, A16 to A20 will combined,
preferably in anew sheet.

Thanks,

Albert

 

[Dave Peterson]

Maybe...

Option Explicit
Sub testme()
Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim DestCell As Range
Dim BigArea As Range
Dim SmallArea As Range

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add
Set DestCell = NewWks.Range("A1")

With CurWks
Set BigArea = Nothing
On Error Resume Next
Set BigArea = .Columns(1).Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0

If BigArea Is Nothing Then
MsgBox "No constants in column A"
Exit Sub
End If

For Each SmallArea In BigArea.Areas
SmallArea.Copy
DestCell.PasteSpecial Transpose:=True
Set DestCell = DestCell.Offset(1, 0)
Next SmallArea
End With

End Sub

This will not do what you want if you have any formulas in column A.

 

[Albert]

Thanks dave that worked out great, the only thing, I need to combine A1 to
A6 in one cell instead of multuple column , I will only one column

Thanks,

Albert

 

[Dave Peterson]

Usually people want the values separated by some kind of delimiter. I used
comma-space. Change it to what you want or use "" if you don't want anything.

Option Explicit
Sub testme()
Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim DestCell As Range
Dim BigArea As Range
Dim SmallArea As Range
Dim myCell As Range
Dim myStr As String
Dim myDelimiter As String

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add
Set DestCell = NewWks.Range("A1")

myDelimiter = ", "

With CurWks
Set BigArea = Nothing
On Error Resume Next
Set BigArea = .Columns(1).Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0

If BigArea Is Nothing Then
MsgBox "No constants in column A"
Exit Sub
End If

For Each SmallArea In BigArea.Areas
myStr = ""
For Each myCell In SmallArea.Cells
myStr = myStr & myDelimiter & myCell.Value
Next myCell
If myStr <> "" Then
myStr = Mid(myStr, Len(myDelimiter) + 1)
End If
DestCell.Value = myStr
Set DestCell = DestCell.Offset(1, 0)
Next SmallArea
End With

End Sub

 

[Albert]

Thanks Dave that's perfect

Usually people want the values separated by some kind of delimiter. I used
comma-space. Change it to what you want or use "" if you don't want anything.

Option Explicit
Sub testme()
Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim DestCell As Range
Dim BigArea As Range
Dim SmallArea As Range
Dim myCell As Range
Dim myStr As String
Dim myDelimiter As String

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add
Set DestCell = NewWks.Range("A1")

myDelimiter = ", "

With CurWks
Set BigArea = Nothing
On Error Resume Next
Set BigArea = .Columns(1).Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0

If BigArea Is Nothing Then
MsgBox "No constants in column A"
Exit Sub
End If

For Each SmallArea In BigArea.Areas
myStr = ""
For Each myCell In SmallArea.Cells
myStr = myStr & myDelimiter & myCell.Value
Next myCell
If myStr <> "" Then
myStr = Mid(myStr, Len(myDelimiter) + 1)
End If
DestCell.Value = myStr
Set DestCell = DestCell.Offset(1, 0)
Next SmallArea
End With

End Sub