Question

我试图将格式化的文本内容从Excel复制到VBA中的Powerpoint - 最好没有复制粘贴，因为它每次运行时都会崩溃（即使有多个DoEvent也会降低速度。）有数百个格式严重的文本单元格。

这就是为什么我一直试图通过直接解决单元格来实现它的工作原理，如下面的代码所示。

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

VBA从Excel复制到PowerPoint（不是＆＃39;复制粘贴＆＃39;）

1 个答案: