VBA pour copier d'Excel vers PowerPoint (Pas 'copier-coller')

Question

J'essaie de copier du contenu texte formaté d'Excel à Powerpoint dans VBA - de préférence sans copier-coller, car il se bloque juste tous les le temps que je l'exécute (même avec DoEvents multiples pour le ralentir ... il y a des centaines de cellules de texte fortement formaté).

C'est pourquoi j'ai essayé de le faire fonctionner en adressant les cellules directement comme dans le code ci-dessous.

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 

Il fonctionne (très rapidement) transférer le contenu cellulaire, nom de la police et de la taille de la police ... mais pas pour FontStyle (gras, italique, etc.) ou FontColor parce qu'il ya plus d'un style/couleur dans des cellules individuelles.

Y a-t-il un moyen de contourner ce problème? Je n'ai pas la moindre idée de ce que la solution potentielle (le cas échéant) pourrait être, alors je ne sais même pas par où commencer à chercher. Même une poussée dans la bonne direction aiderait énormément.

Answer 1

ici est une preuve de concept

cellules de copie d'Excel dans powerPoint

spécifiques: les cellules ont de multiples mise en forme de texte par cellule

obtenu en copiant dans le document Msword puis de Msword en 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