将excel中的文本格式复制到word脚本

Question

我有一个正常运行的脚本，它将目标文本从 Excel 工作表复制到打开的 Word 文档，但我想知道它是否也可以复制文本上的格式，这意味着某些文本是 粗体和下划线。目前，它只是将文本复制到 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 应用程序（请参阅here，了解有关 Excel->PowerPoint 的类似问答），并且如上所述：

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

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

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

您需要一个 idMso 参数列表来探索，这是一个相当大的可下载文件的一部分，我相信它适用于 Office 2013：

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