multiple cells text to text in one cell

[CG Rosen]

Hi Group,

Have a table with abt 5000 posts that need to be edited.
The structure of the table is:
A B C
1 100 aaaaaa xxxxx
bbbbbbbbb yyyyyyyyy
ccc

Looking for a result like this after editing
A B C
1 100 aaaaaa bbbbbbbbb ccc xxxxx yyyyyyyyy

The result in row 1 should be the identifing number and two joined text
strings in separate columns.

Have looked round in the group and found the code below but has not been
able to modify it
for the purpose.

Grateful for some hints,

Brgds

CG Rosen
'----------------------------------------------------------------------------------------------
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(3).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

 

[Don Guillett]

try this

Sub lineemep()
dim lr as long
dim i as long

lr = Cells.Find("*", Cells(Rows.Count, Columns.Count) _
, , , xlByRows, xlPrevious).Row
For i = lr To 2 Step -1
If Len(Application.Trim(Cells(i, 1))) <= 1 Then
Cells(i - 1, 2) = Cells(i - 1, 2) & " " & Cells(i, 2)
Cells(i - 1, 3) = Cells(i - 1, 3) & " " & Cells(i, 3)
Rows(i).Delete
End If
Next i
Columns(1).Resize(, 3).AutoFit
End Sub

 

[CG Rosen]

Hi Don,

Thanks a lot. Works perfect

Brgds

CG Rosen

 

[Don Guillett]

Glad to help.