复制文本中的Excel格式，以文字脚本

Question

我有一个正常运作的脚本，它会复制一个Excel工作表有针对性的文字到打开的Word文档，但我想知道如果可能的话，它还会复制的文本格式，意思是一些文字是Bold并加下划线。目前，它只是将文本复制到单词中。

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变量中仅存储原始文本。

让我们也有附加的子程序清理它，因为你重复​​循环在几个不同范围的对象。

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类似的Q & A，并且如上所述：

与许多其他方法相比，CommandBars.ExecuteMso没有很好的记录。该Application.CommandBarsproperty 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