Question

我有一个11页的Excel工作簿，页面上有多个图表，只有一些页面上的文字，单个图表和所有类型的东西。我只想将每个工作表导出到PowerPoint演示文稿的一张幻灯片中。

以下是我发现的一些代码，它们将所有图表和文本导出到一张幻灯片中，这不是我需要的（这是我经常使用的代码）：

 'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

    'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125

        activeSlide.Shapes(2).Width = 200
        activeSlide.Shapes(2).Left = 505

    Next

AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

现在我有一些导出我以编程方式创建的表的代码，但是当我尝试导出Excel演示文稿时出错：

Sub ExportToPPT()


Dim ws As Worksheet

'Open Power Point and create a new presentation.
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Add

'Show the Power Point application.
pptApp.Visible = True

For Each ws In ActiveWorkbook.Worksheets
    ws.Activate
    ExcelTableToPowerPoint (ActiveSheet.Range("A1:L5"))
Next ws

'Return the "focus" to the frist sheet.
ActiveWorkbook.Worksheets(1).Activate

'Infrom the user that the macro finished.
MsgBox "The ranges were successfully copied to the new presentation!", vbInformation, "Done"

End Sub

Answer 1

得到了我的答案的解决方案，希望这有助于其他人：

 'variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim SlideCount As Long
Dim row As Long

'pp variable = Create a new powerpoint presentation
Set pp = CreateObject("PowerPoint.Application")

'Powerpoint presentation = add the object (the finished product) to the poewrpoint presentation
Set PPPres = pp.Presentations.Add

'powerpoint is now visible
pp.Visible = True

'range you pick for selection
MyRange = "A2:U41"

'For each worksheet in the active workbook select all the worksheets and wait however many seconds
For Each xlwksht In ActiveWorkbook.Worksheets
    xlwksht.Select
    Application.Wait (Now + TimeValue("0:00:1"))

    'copy the picture from the range you selected
    xlwksht.Range(MyRange).CopyPicture _
    Appearance:=xlScreen, Format:=xlPicture

    'Slide count
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
    PPSlide.Select

    'paste the shapes
    PPSlide.Shapes.Paste

    pp.ActiveWindow.Selection.ShapeRange.Top = 1
    pp.ActiveWindow.Selection.ShapeRange.Left = 1
    pp.ActiveWindow.Selection.ShapeRange.Width = 700


Next xlwksht

pp.Activate

'Cleans it up
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing

将整个Excel工作簿导出到PowerPoint演示文稿

1 个答案: