Need macro that concatenates cells with text

  • Thread starter Thread starter andrei
  • Start date Start date
A

andrei

I have in column A cells with the following content :

A1 : Mother
A2 : go
A3 : home
A4 : ( empty cell)
A5: ( empty cell)
A6 : Daddy
A7 : works
A8 : in a
A9 : mine
A10 : (empty cell)
A11 : My uncle
A12 : is a spy

What i want in a macro which does that

B1 : Mother go home
B2 : Daddy works in a mine
B3 : My uncle is a spy

The macro should concatenate the cells with text and "understand" empty
cells as delimiter .
 
Give this a try:

Sub sentences()
Dim n As Long, k As Long
Dim s As String, v As String
n = Cells(Rows.Count, 1).End(xlUp).Row + 1
k = 1
s = ""
For i = 1 To n
v = Cells(i, 1).Value
If v <> "" Then
If s = "" Then
s = v
Else
s = s & " " & v
End If
Else
If Cells(i - 1, 1).Value = "" Then
Else
Cells(k, 2).Value = s
s = ""
k = k + 1
End If
End If
Next
End Sub
 
Assuming your cells contain text (as your post indicated they did) and not
formulas, give this code a try (set the DataStartCell and the
DestinationStartCell for your actual setup)....

Sub Concatter()
Dim X As Long, Off As Long, R As Range, LastCell As Range
Dim DataStartCell As Range, DestinationStartCell As Range
Set DataStartCell = Range("A1")
Set DestinationStartCell = Range("B1")
Set LastCell = Cells(Rows.Count, DataStartCell.Column).End(xlUp)
Set R = Range(DataStartCell, LastCell).SpecialCells(xlCellTypeConstants)
For X = 1 To R.Areas.Count
DestinationStartCell.Offset(Off).Value = _
Join(WorksheetFunction.Transpose(R.Areas(X)))
Off = Off + 1
Next
End Sub
 
Hi,

Right click your sheet tab, view code and paste the code below in and run it,

Sub sonic()
Dim OutRow As Long, Lastrow As Long
Dim TempString As String
OutRow = 1
Lastrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Range("A1:A" & Lastrow)
For Each c In MyRange
If c.Value = "" Then GoTo getmeout
TempString = TempString & c.Value & " "
If c.Offset(1).Value = "" Then
Cells(OutRow, 2).Value = Trim(TempString)
TempString = ""
OutRow = OutRow + 1
End If
getmeout:
Next
End Sub


Mike
 
For instruction purposes, if we eliminate the generalization code and simply use the source and destination cells you indicated, we can make my code look a lot less scary<g>....

Sub Concatter()
Dim X As Long, Off As Long, R As Range
Set R = Range(Range("A1"), Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants)
For X = 1 To R.Areas.Count
Range("B1").Offset(Off).Value = Join(WorksheetFunction.Transpose(R.Areas(X)))
Off = Off + 1
Next
End Sub

Again, this assumes the cells contain text constants.
 
Very Nice!
--
Gary''s Student - gsnu200905


Rick Rothstein said:
Assuming your cells contain text (as your post indicated they did) and not
formulas, give this code a try (set the DataStartCell and the
DestinationStartCell for your actual setup)....

Sub Concatter()
Dim X As Long, Off As Long, R As Range, LastCell As Range
Dim DataStartCell As Range, DestinationStartCell As Range
Set DataStartCell = Range("A1")
Set DestinationStartCell = Range("B1")
Set LastCell = Cells(Rows.Count, DataStartCell.Column).End(xlUp)
Set R = Range(DataStartCell, LastCell).SpecialCells(xlCellTypeConstants)
For X = 1 To R.Areas.Count
DestinationStartCell.Offset(Off).Value = _
Join(WorksheetFunction.Transpose(R.Areas(X)))
Off = Off + 1
Next
End Sub
Click to expand...
 
Thanks, but I'm sure it looks kind of "scary" to the majority of readers in its generalized form; hence my second, less scary looking (hopefully<g>) posting of the same code with all the generalizations removed.
 
Back
Top