從Excel復制到PowerPoint的VBA（不是“復制粘貼”）

Question

我正在嘗試將格式化的文本內容從Excel復制到VBA中的Powerpoint中-最好不要進行復制和粘貼，因為每次運行它都會崩潰（即使有多個DoEvent來降低它的速度...也有數百個高度格式化的文本單元格）。

這就是為什么我一直試圖通過像下面的代碼中那樣直接尋址單元來使其工作。

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