0

我有一个 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
4

1 回答 1

0

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

 '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
于 2013-11-07T21:45:12.087 回答