複製文本中的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