VBA從Excel複製到PowerPoint（不是「複製和粘貼」）

Question

我試圖將格式化的文本內容從Excel複製到Powerpoint的VBA中 - 最好沒有複製和粘貼，因爲它只是崩潰每一個當我運行它（即使有多個DoEvents來減慢速度...有數百個格式嚴格的文本）。

這就是爲什麼我一直試圖通過像下面的代碼中直接尋址單元格來使它工作。

For i = 1 To WS.Range("A65536").End(xlUp).Row 
    If WS.Cells(i, 1) > 0 Then  
     Set newSlide = ActivePresentation.Slides(1).Duplicate 
     newSlide.MoveTo (ActivePresentation.Slides.Count) 

     With newSlide.Shapes(1).TextFrame.TextRange 
      .Text = WS.Cells(i, 1).Value ' Inserts the (non-formatted) text from Excel. Have also tried WS.Cells(i, 1).Text 
      .Font.Name = WS.Cells(i, 1).Font.Name ' This works fine 
      .Font.Size = WS.Cells(i, 1).Font.Size ' This works fine too 

      ' Neither of the below work because there is a mixture of font styled and colours within individual cells 
      .Font.FontStyle = WS.Cells(i, 1).Font.FontStyle ' Font Style (Regular, Bold, Italic, Bold Italic) 
      .Font.Color = WS.Cells(i, 1).Font.Color ' Font Color 
     End With 
    End If 
Next 

它的工作原理（非常快），使單元的內容，字體名稱和字體大小...但不使用FontStyle（粗體，斜體等）或FONTCOLOR因爲有多個樣式/顏色在個別細胞中。

有沒有辦法解決這個問題？我不知道潛在的解決方案（如果有的話）可能是什麼，所以甚至不知道從哪裏開始尋找。即使向正確的方向推動也會有很大的幫助。

Answer 1

這裏是從Excel證明的概念

複製單元格到PowerPoint

細節：細胞具有每個細胞

多種文本格式

被複制到MSWORD文檔，然後從MSWORD爲實現powerPoint

Sub copyMultipleColorTextPerCell() 

    ' this program copies excel cells that contain multiply formatted text in each cell 
    ' the text is copiend into an msWord document, because the formatting is retained 
    ' and then copied into powerpoint 


    ' -------------------------- create powerpoint presentation 

    Const ppLayoutBlank = 12 

    Dim ppApp As PowerPoint.Application 

    On Error Resume Next 
    Set ppApp = GetObject(, "PowerPoint.Application") 
    On Error GoTo 0 

    If ppApp Is Nothing Then 
     Set ppApp = New PowerPoint.Application 
    End If 

    ppApp.Visible = True 

    Dim ppPres As Presentation 
    Set ppPres = ppApp.Presentations.Add 

    Dim ppSlid As PowerPoint.Slide 
    Set ppSlid = ppPres.Slides.Add(1, 1) 

    ppSlid.Layout = ppLayoutBlank 

    Dim ppShp As PowerPoint.Shape 
    Set ppShp = ppPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 500, 200) 

    Dim ppTxRng As PowerPoint.TextRange 
    Set ppTxRng = ppShp.TextFrame.TextRange 

    ' --------------------------------------------------------------- 

    Dim wdApp As Word.Application        ' not necessary 
    Set wdApp = New Word.Application 

    Dim xlRng As Excel.Range 
    Set xlRng = Sheets("Sheet1").Range("c6:c7")     ' this is the range that gets copied into powerPoint, via msWord 

    xlRng.Cells(1) = "this is multicolor text"     ' some multicolour test text, so you don't have to type any 
    xlRng.Cells(1).Characters(1, 13).Font.Color = vbGreen 
    xlRng.Cells(1).Characters(14, 20).Font.Color = vbRed 

    xlRng.Cells(2) = "this is also multicolor" 
    xlRng.Cells(2).Characters(1, 12).Font.Color = vbBlue 
    xlRng.Cells(2).Characters(13, 20).Font.Color = vbMagenta 

    Dim wdDoc As Word.Document 
    Set wdDoc = New Word.Document 

    Dim wdRng As Word.Range 
    Set wdRng = wdDoc.Range 

    xlRng.Copy         ' copy whole excel range 
    wdRng.PasteExcelTable False, False, False  ' paste to msWord doc, because formatting is kept 

    Dim wdTb As Table 
    Set wdTb = wdDoc.Tables(1) 

    ' copy the two cells from msWord table 
    wdDoc.Range(start:=wdTb.Cell(1, 1).Range.start, End:=wdTb.Cell(2, 1).Range.End).Copy 

    ppTxRng.Paste         ' paste into powerPoint text table 
    ppTxRng.PasteSpecial ppPasteRTF 

    Stop           ' admire result ...... LOL 

    wdDoc.Close False 
    ppPres.Close 
    ppApp.Quit 

    Set wdDoc = Nothing 
    Set wdApp = Nothing 
    Set ppSlid = Nothing 
    Set ppPres = Nothing 
    Set ppApp = Nothing 

End Sub