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

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