将Excel中的文本格式复制到Word脚本

Question

我有一个运行正常的脚本，它可以将目标文本从Excel工作表复制到打开的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

是的，我认为这应该可行，但是需要对代码进行一些结构上的更改。 您将需要在Word中复制“粘贴”操作，而不是（如您当前正在执行的那样） 仅将原始文本存储在sData ， tData和uData变量中。

我们还要用一个附加的子例程来清理它，因为您要在几个不同的范围对象上重复For Each r循环。

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

这是一些示例输出，其中保留了所有文本格式（粗体，下划线，字体颜色等）。

这应该适用于所有Office应用程序（有关Excel-> PowerPoint的类似问答，请参见此处 ），并且如上所述：

与许多其他方法相比， CommandBars.ExecuteMso的文档记录不是很好。 Application.CommandBars 属性参考甚至没有提到ExecuteMso方法，我在这里找到了一些信息：

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

在没有特定命令的对象模型的情况下，此方法很有用。 适用于内置按钮，toggleButtons和splitButtons控件。

您需要探索一个idMso参数列表， 这些参数是一个相当大的可下载文件的一部分，该文件是Office 2013的最新版本，我相信：

http://www.microsoft.com/zh-cn/download/details.aspx?id=727