VBA to copy from Excel to PowerPoint (Not 'copy-and-paste')

Question

I'm trying to copy formatted text content from Excel to Powerpoint in VBA--preferably without copy-and-paste, as it just crashes every time I run it (even with multiple DoEvents to slow it down... there are hundreds of cells of heavily formatted text).

That's why I've been trying to get it to work by addressing the cells directly like in the code below.

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

It works (very quickly) transferring the cell content, font name, and font size... but NOT for FontStyle (bold, italics, etc.) or FontColor because there is more than one style/color in individual cells.

Is there any way around this? I haven't the foggiest idea what the potential solution (if any) could be, so don't even know where to start looking. Even a push in the right direction would help enormously.

Answer 1

here is a proof-of-concept

copying cells from excel into powerPoint

specifics: cells have multiple text formatting per cell

achieved by copying into msWord document and then from msWord into 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