通过Excel VBA保存并closuresPowerPoint

以下代码根据定义的名称创build多个图表,然后使用这些定义的名称和图表中的转储打开PowerPoint文件。 除了最后一部分,我有一切工作:保存并closures文件。

我用绿色标记了我试图保存和closures文件的尝试。 任何帮助表示赞赏!

Sub Slide19() Dim rngx As Range Dim rngy As Range Dim rngz As Range Dim ws As Worksheet Dim ws1 As Worksheet Dim ws2 As Worksheet Dim icnt As Long Dim lastrow As Long Dim k As Long Dim icounter As Long Dim a As Long Dim b As Long Dim c As Long Dim d As Variant Dim Chart As ChartObject Dim PPapp As Object Dim PPTDoc As PowerPoint.Presentation Dim PPT As PowerPoint.Application Dim PPpres As Object Dim pptSlide As PowerPoint.Slide Dim ppslide As Object Dim filename As String Dim filename2 As String Set ws = Worksheets("Reference") Set ws1 = Worksheets("Levels") Set ws2 = Worksheets("Slide 19") ws2.Activate ws2.Range("e:f").NumberFormat = "0%" lastrow = ws2.Cells(Rows.Count, "b").End(xlUp).Row For icounter = 1 To lastrow For icnt = 14 To 20 If ws2.Cells(icounter, 2) = ws.Cells(icnt, 3) Then 'd = ws.Cells(icnt, 3) a = icounter + 1 b = icounter + 2 c = icounter + 12 filename = "filepath" & ws2.Cells(icounter, 2) & ".pptx" filename2 = "xxyyxx" & ws2.Cells(icounter, 2) 'create RBI Vs LTM Set rngx = Range(Cells(a, 4), Cells(c, 4)) Set rngy = Range(Cells(a, 5), Cells(c, 6)) ws2.Shapes.AddChart.Select ' ActiveChart.Name = ws2.Cells(icounter, 2) & "Slide8" ActiveChart.ChartType = xlColumnClustered ActiveChart.SetSourceData Source:=Union(rngx, rngy), PlotBy:=xlColumns With ActiveChart '.Name = d & "Slide8" .SetElement (msoElementChartTitleAboveChart) .ChartGroups(1).Overlap = 0 .Legend.Delete .ChartTitle.Select .ChartTitle.Text = "Engagement by Level" .SeriesCollection(1).ApplyDataLabels .SeriesCollection(2).ApplyDataLabels .SeriesCollection(1).Interior.Color = RGB(0, 101, 179) .SeriesCollection(2).Interior.Color = RGB(192, 80, 77) .Axes(xlValue).MaximumScale = 1 ' .Axes(xlValue).MinimumScale = 0.5 '.Height = 374.4 '.Width = 712.8 .Axes(xlValue).TickLabels.NumberFormat = "0%" .SetElement (msoElementLegendRight) End With ActiveChart.Axes(xlValue).MajorGridlines.Select Selection.Format.Line.Visible = msoFalse ActiveChart.Legend.Select Selection.Left = 466.71 Selection.Top = 12.467 Set rngx = Nothing Set rngy = Nothing With ActiveChart.Parent .Height = Application.InchesToPoints(5.2) .Width = Application.InchesToPoints(9.9) End With Set PPapp = CreateObject("Powerpoint.Application") Set PPT = New PowerPoint.Application PPT.Presentations.Open filename:=filename PPapp.ActiveWindow.View.GotoSlide Index:=9 ActiveChart.ChartArea.Copy PPapp.ActiveWindow.Panes(1).Activate PPapp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting" 'PPT.ActivePresentation.SaveAs filename 'PPT.Presentations(filename2).Close 'PPapp.Quit 'PPT.Presentations.Close End If 'PPapp.Quit Next icnt Next icounter 'PPapp.Quit End Sub 

您的代码保存并closures演示文稿应该正常工作。 唯一要做的就是在保存和closures之间join等待function,因为closures线不会“等待”保存导致错误。

 PPT.ActivePresentation.SaveAs filename waiting(7) 'For my usage 7 seconds waiting is enough - it depends on size of your presentation PPT.Presentations(filename2).Close 

等待的function:

 Sub waiting(tsecs As Single) Dim sngsec As Single sngsec = Timer + tsecs Do While Timer < sngsec DoEvents Loop End Sub 

之后你可以使用:

 PPT.Quit set PPT = Nothing 

我只是testing了下面这个打开一个Powerpoint实例,使其可见,创build一个演示文稿,保存演示文稿(path将需要改变),退出应用程序并释放variables。 请让我知道如果这不符合您的需求。

 Sub ppt() Dim ppt As New PowerPoint.Application Dim pres As PowerPoint.Presentation ppt.Visible = True Set pres = ppt.Presentations.Add pres.SaveAs "C:\Users\xxx\Desktop\ppttest.pptx" pres.Close ppt.Quit Set ppt = Nothing End Sub