VBA: Concatenating to cells while maintaining partial formatting

I have a column of cells with normal formatting. Next to it I have a column of cells which has text starting with bold and underline and then there is normal text. I need to combine the first column with the second column such that the formatting is maintained ie normal font then bold font and then normal font.
LVL 43
Saqib Husain, SyedEngineerAsked:
Who is Participating?
dlmilleConnect With a Mentor Commented:
Modifying the HTML might be simple for some, but not for me.

There is a simpler solution, though you MAY or MAY not like the outcome.  The result may be much quicker than all the formatting handling on a cell by cell basis, but the results are in WORD.  It really depends on what your end game is.  If it is to print the document, or make a PDF of it, then perhaps WORD is a solution that works.

What I couldn't seem to do was get the Word data back into Excel.  Manually copying/pasting the document ended up splitting the data onto multiple lines.  There MAY be a way to do it cell by cell, but I haven't figured that, yet.

Anyhow, it was fun to work between the two apps and pick up a bit more education on WORD.

Here's the code:
Option Explicit
Sub do_it_all()
Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim r As Range
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim tableNo As Integer
Dim iRow As Long
Dim iCol As Long
Dim fName As String

    Set wkb = ThisWorkbook
    Set wks = wkb.ActiveSheet

    fName = ThisWorkbook.path & "\myOutput.doc"
    Set oWordApp = CreateObject("Word.Application")
    oWordApp.Visible = True
    Set oWordDoc = oWordApp.Documents.Add

    Set rng = wks.Range("A2", wks.Range("B" & wks.Rows.Count).End(xlUp))  'range to be converted

    oWordDoc.Range.PasteExcelTable linkedtoexcel:=False, wordformatting:=False, RTF:=False
    With oWordDoc.Tables(1)
        'introduce duplicate column for Excel Column A
        'merge each row, as requested
        For iRow = 1 To .Rows.Count
            .Cell(iRow, 2).Merge mergeto:=.Cell(iRow, 3)
        Next iRow
    End With

    'save the word document
    oWordDoc.SaveAs2 Filename:=fName, FileFormat:=wdFormatDocument


    Exit Sub 'temporarily keep the word document open.  Comment this out to close out Word on completion
    'do cleanup
    If Not oWordDoc Is Nothing Then
        oWordDoc.Close savechanges:=False
        Set oWordDoc = Nothing
    End If

    If Not oWordApp Is Nothing Then
        Set oWordApp = Nothing
    End If
End Sub

Open in new window

See attached.  I'm interested whether you think this adds value to your endeavor.

Peter KwanAnalyst ProgrammerCommented:
Please try the following code (Ref: http://www.mrexcel.com/forum/showthread.php?t=612120):

Sub ConcatenateRichText(Target As Range, Source As Range)
    Dim Cell As Range
    Dim i As Long
    Dim c As Long
    i = 1
    With Target
        For Each Cell In Source
            .Value = .Value & vbCrLf & Cell.Value
        Next Cell
        .Value = Mid(.Value, 3)
        .Value = Trim(.Value)
    End With
    For Each Cell In Source
        For c = 1 To Len(Cell.Value)
            With Target.Characters(i, 1).Font
                .Name = Cell.Characters(c, 1).Font.Name
                .FontStyle = Cell.Characters(c, 1).Font.FontStyle
                .Size = Cell.Characters(c, 1).Font.Size
                .Strikethrough = Cell.Characters(c, 1).Font.Strikethrough
                .Superscript = Cell.Characters(c, 1).Font.Superscript
                .Subscript = Cell.Characters(c, 1).Font.Subscript
                .OutlineFont = Cell.Characters(c, 1).Font.OutlineFont
                .Shadow = Cell.Characters(c, 1).Font.Shadow
                .Underline = Cell.Characters(c, 1).Font.Underline
                .ColorIndex = Cell.Characters(c, 1).Font.ColorIndex
            End With
            i = i + 1
        Next c
        i = i + 2
    Next Cell
End Sub

Sub ConcatCells()
    For i = 2 To Sheet1.UsedRange.Rows.Count

        ConcatenateRichText Sheet1.Range("F" & i), Sheet1.Range("A" & i & ",B" & i & "")

End Sub

Open in new window

Saqib Husain, SyedEngineerAuthor Commented:
This is horrendously slow. My data has something like 1000 characters in each cell and the way the program goes I might be able to do it faster manually.
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

Saqib Husain, SyedEngineerAuthor Commented:
But it does do what I want it to.
Saqib Husain, SyedEngineerAuthor Commented:
It also fails in some instances, probably where cells do not have partial formatting but both source cells have different formats.
Saqib - this can be done very quickly (in execution, it will take me a few to pull the code together:P), as you have IMHO a simple problem from the perspective I've been working on a solution this past day - and that's making heads/tails of HTML.

So, my brainstorm is to write the range in column B into HTML, then parse that range adding the text from column A, then open that file in Excel and copy/paste the amended values to the result column.

I'm working on it, now.

BitsqueezerConnect With a Mentor Commented:

the code above assumes that it doesn't know the formatting of your cell so it tries to scan any character and set the formatting of any single character again.

If you have the same formatting in all of your cells, that means: it starts with a bold underline text and has a normal formatted text after this headline you can speed the things by using the following code:

Public Sub AddText()
    Dim lngULOff As Long
    Dim strAddText As String
    Dim rng As Excel.Range
    Dim i As Long
    For i = 2 To ActiveSheet.UsedRange.Rows.Count
        strAddText = Range("A" & i).Value
        Set rng = Range("B" & i)
        lngULOff = GetUnderlineEnd(rng)
        rng.Value = strAddText & vbLf & rng.Value
        With rng.Characters(Start:=1, Length:=Len(rng.Value)).Font
            .Name = "Arial"
            .FontStyle = "Regular"
            .Underline = xlUnderlineStyleNone
        End With
        With rng.Characters(Start:=Len(strAddText) + 1, Length:=lngULOff).Font
            .FontStyle = "Bold"
            .Underline = xlUnderlineStyleSingle
        End With
End Sub

Public Function GetUnderlineEnd(rngCell As Excel.Range) As Long
    Dim i As Long
    For i = 1 To rngCell.Characters.Count
        With rngCell.Characters(i, 1)
            If .Font.Underline = xlUnderlineStyleNone Then
                GetUnderlineEnd = i
                Exit For
            End If
        End With
End Function

Open in new window

It uses a function to find out the first position where the content of a cell is not underlined, then inserts the text of column A to column B, format the complete cell as normal text and then format the text beginning with the length of the text of column A +1 to the found length. The result is what you want to have. If you have different formattings in your cells you will need to add additional logic to this sub.



Remember to use Application.ScreenUpdating = False before your bulk updates.

Restore your application UI activity with Application.ScreenUpdating = True after you bulk updates.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.