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

我试图将格式化的文本内容从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，因为单个单元格中有多个样式/颜色。

有没有办法解决？ 我不知道潜在的解决scheme（如果有的话）是什么，所以甚至不知道从哪里开始寻找。 即使是向正确的方向推进也将有很大的帮助。

Answer 1

这是一个概念validation

将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