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

Question

我试图将格式化的文本内容从Excel复制到Powerpoint的VBA中 - 最好没有复制和粘贴，因为它只是崩溃每一个当我运行它（即使有多个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