Copy text formatting in a excel to word script

Question

I have a functioning script, it copies targeted text from an Excel sheet to an open Word document, but I'm wondering if it's possible that it also copies the formatting on the text, meaning some of the text is Bold and underlined. Currently, it just copies the text over to word.

Sub Updated_Excel_Data_to_Word()
    Dim rYes As Range, r As Range
    Dim sData As String
    Dim tData As String
    Dim uData As String
    Dim objWord As Object


    Set rYes = Range("B2:B34")


    For Each r In rYes
        If r = "X" Then

            sData = sData & r.Offset(0, 1) & Chr(13)
        End If
    Next r


     Set rYes = Range("F2", Range("F" & Rows.Count).End(xlUp))


    For Each r In rYes
        If r = "X" Then

            tData = tData & r.Offset(0, 1) & Chr(13)
        End If
    Next r



     Set rYes = Range("J2", Range("J" & Rows.Count).End(xlUp))


    For Each r In rYes
        If r = "X" Then

            uData = uData & r.Offset(0, 1) & Chr(13)
        End If
    Next r





    Set objWord = GetObject(, "word.application")

    objWord.activeDocument.Bookmarks("One").Select
    objWord.Selection.TypeText (sData)
    objWord.activeDocument.Bookmarks("Two").Select
    objWord.Selection.TypeText (tData)
    objWord.activeDocument.Bookmarks("Three").Select
    objWord.Selection.TypeText (uData)
End Sub

Answer 1

Yes, I think this should be possible but requires some structural changes to your code. You'll need to replicate the "paste" operation in Word, instead of (as you are currently doing) storing only the raw text in your sData, tData, uData variables.

Let's also clean this up with an additional subroutine, since you're repeating the For Each r loop over a few different range objects.

Sub Updated_Excel_Data_to_Word()

    Dim rYes As Range
    Dim objWord As Object

    ' Get a handle on Word Application
    Set objWord = GetObject(, "word.application")

    ' Assign the range
    Set rYes = Range("B2:B34")

    ' Pass the range and Word object variables to the helper function
    Call PasteValuesToWordBookmark(rYes, objWord, _
                                   objWord.activeDocument.Bookmarks("One"))

    ' repeat as needed, just changing the range & bookmarks
    Set rYes = Range("F2", Range("F" & Rows.Count).End(xlUp))

    Call PasteValuesToWordBookmark(rYes, objWord, _
                                   objWord.activeDocument.Bookmarks("Two"))

    Set rYes = Range("J2", Range("J" & Rows.Count).End(xlUp))

    Call PasteValuesToWordBookmark(rYes, objWord, _
                                  objWord.activeDocument.Bookmarks("Three"))

End Sub

Sub PasteValuesToWordBookmark(rng as Range, wdApp as Object, _
                              wdBookmark as Object)
    Dim r as Range

    For Each r In rng
        If r = "X" Then
            wdBookmark.Select
            r.Offset(0, 1).Copy  'Copy the cell from Excel
            'in my testing this automatically adds a carriage return, so 
            ' we don't need to explicitly append the Chr(13)/vbCR character
            wdApp.CommandBars.ExecuteMSO "PasteSourceFormatting"
        End If
    Next r

End Sub

Here is some example output which has preserved all of the text formatting (bold, underline, font color, etc.)

This should work across all Office applications (see here for a similar Q&A regarding Excel->PowerPoint), and as mentioned:

The CommandBars.ExecuteMso is not very well-documented compared to many other methods. The Application.CommandBars property reference doesn't even mention the ExecuteMso method, which I found some information about here:

http://msdn.microsoft.com/en-us/library/office/ff862419(v=office.15).aspx

This method is useful in cases where there is no object model for a particular command. Works on controls that are built-in buttons, toggleButtons and splitButtons.

You'll need a list of idMso parameters to explore, which come as part of a rather large downloadable file, current for Office 2013 I believe:

http://www.microsoft.com/en-us/download/details.aspx?id=727