VBA 从 Excel 复制到 PowerPoint（不是“复制和粘贴”）

Question

我正在尝试将格式化的文本内容从 Excel 复制到 VBA 中的 Powerpoint——最好不要复制和粘贴，因为它每次运行时都会崩溃（即使有多个 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