Need VBA to join cells into one single cell in other column

[skyport]

Need VBA to join cells in column A and put into one single cell in column B. However, the result in column B needs to retain bold and underlining aspects that exist in some of the data in part of each cell in column A

I am currently using the following code which joins the cells ok, however does not retain the parts in bold or underlined that are in column A. Hoping someone can help.

Sub JoinThem2()
Dim i As Long
Dim s As String

For i = 1 To Range("E" & Rows.Count).End(xlUp).Row
s = s & Cells(i, "E").Value
Next i
Range("K1").Value = s
End Sub

 

[sergioMabres]

Yes it is very slow and Bold is missing :|
Thanks so much Peter

 

[Teeroy]

Teeroy may have a different idea but I think the blue changes would be one way.

The red changes should speed the code a reasonable amount too.

Sub JoinThem3()
Dim i As Long
Dim j As Integer
Dim s As String
Dim cBold As New Collection
Dim cUnderline As New Collection

Const Delim As String = ","

Application.ScreenUpdating = False
With Range("K1")
    .ClearContents
    For i = 1 To Range("E" & Rows.Count).End(xlUp).Row
        s = s & Delim & Cells(i, "E").Value
        For j = 1 To Len(Cells(i, "E")) + Len(Delim)
            cBold.Add Cells(i, "E").Characters(Start:=j, Length:=1).Font.Bold
            cUnderline.Add Cells(i, "E").Characters(Start:=j, Length:=1).Font.Underline
        Next j
    Next i
    .Value = Mid(s, Len(Delim) + 1)
    For i = 1 To Len(.Cells(1, 1))
        .Characters(Start:=i, Length:=1).Font.Bold = cBold(i)
        .Characters(Start:=i, Length:=1).Font.Underline = cUnderline(i)
    Next i
End With
Application.ScreenUpdating = True
End Sub

Peter, it's a very reasonable change and extremely unlikely I'd have a different idea as a lot of the coding I've learned is from moderators and MVPs here (yourself included ). I still want to try the multi-application approach though and I'll post when I get a chance to do it.

 

[Teeroy]

Didn't take as long as expected; the Google was strong today (Don't blame me Star Wars ads have been running ).

For comparison, you can try using a combination of Excel and Word with:

Sub test_JoinThem4()
Dim objWord As Object, objDoc As Object, objSelection As Object
Dim lLastRow As Long
Dim rng As Range
Const delimeter = ","

Set objWord = CreateObject("Word.Application")
objWord.Visible = False
Set objDoc = objWord.Documents.Add
lLastRow = Cells(Rows.Count, "E").End(xlUp).Row
For Each rng In Range("E1:E" & lLastRow)
    rng.Copy
    Set objSelection = objWord.Selection
    objSelection.Endkey 6, 0
    objSelection.PasteExcelTable False, False, False
    objSelection.TypeBackspace
    If Len(rng) > 0 Then
        objSelection.InsertAfter (delimeter)
    End If
Next
objSelection.TypeBackspace
objSelection.WholeStory
objSelection.Copy
Range("K1").Select
ActiveSheet.Paste

objDoc.Close SaveChanges:=False
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub

I don't know which is quicker, I haven't checked. If you do test this then please let me know which is quicker.

 

[Peter_SSs]

I don't know which is quicker, I haven't checked. If you do test this then please let me know which is quicker.

I didn't do any formal timing but ball-park same as before:

For about 20 cells with 1,400+ characters, ... about 4-5 seconds ...

 

[István Hirsch]

Teeroy, I sure appreciate your help. The problem I encountered with the word doc idea is only one major issue. it won't join the cells without leaving a partial line of blank space at the end of each cell data.

Also, with your code, is there a way to do what I was asking above about the space/comma or periods?

If you process more data along with a wider variety of formattings (including colours, for example) and processing takes a long time, copy the column to Word, convert the table to text, and replace paragraph marks with any delimiter you like.