Attribute VB_Name = "autoPPT" '******************** Code Start ************************** ' You are free to use it in any application, ' provided the copyright notice is left unchanged. ' Function: Copy chart from excel to power point. ' Vincent From www.veryword.com Sub AutoPPT() Dim p_path As String p_path = ActivePresentation.Path Dim Count As Integer Dim k As Integer Dim LoopName As Variant LoopName = Array("1", "2", "3", "4", "5") Set PPT = New PowerPoint.Application PPT.Visible = True Count = InputBox("Please input the number of excel files.") Set newPres = Presentations.Add(True) newPres.SaveAs "PPT" For k = 1 To 5 Dim objExcel As Object Set objExcel = CreateObject("Excel.Application") objExcel.Visible = False objExcel.Workbooks.Open (p_path & "\Excel" & Count & ".xls") objExcel.Charts(6 - k).Activate objExcel.activeworkbook.Save objExcel.activeworkbook.Close ActivePresentation.ApplyTemplate FileName:=p_path & "\template.pot" ActivePresentation.Slides.Add 1, ppLayoutBlank ActivePresentation.Slides(1).Select ActiveWindow.Selection.SlideRange.Shapes.AddOLEObject(Left:=75#, Top:=125#, Width:=750#, Height:=450#, FileName:=p_path & "\Excel" & Count & ".xls", Link:=msoFalse).Select With ActiveWindow.Selection.ShapeRange .ScaleWidth 0.78, msoFalse, msoScaleFromTopLeft .ScaleHeight 0.78, msoFalse, msoScaleFromTopLeft End With ActiveWindow.Selection.Unselect ActiveWindow.Selection.SlideRange.Layout = ppLayoutTitleOnly ActiveWindow.Selection.SlideRange.Shapes.SelectAll ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select With ActiveWindow.Selection.TextRange .Text = "Excel" & Count & " " & "Chart" & LoopName(5 - k) With .Font .NameAscii = "Arial" .Size = 40 .Bold = msoFalse .Italic = msoFalse .Underline = msoFalse .Shadow = msoFalse .Emboss = msoFalse .BaselineOffset = 0 .AutoRotateNumbers = msoFalse .Color.SchemeColor = ppTitle End With End With ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=10, Length:=8).Select ActiveWindow.Selection.TextRange.Font.Size = 40 ActiveWindow.Selection.Unselect Next k newPres.Save End Sub