Excel 通过更新图表生成多个powerpoint文件

Excel 通过更新图表生成多个powerpoint文件,excel,vba,Excel,Vba,我需要通过更新每行可用excel数据(动态行计数)第二张幻灯片中的图表来生成多个powerpoint文件 我有一个excel文件,大约有1000行(每次计数都是动态的),每行都是一个记录,根据1行,我在excel中创建了一个图表,我需要将其复制到现有ppt模板的第二张幻灯片中。因此,通过这种方式,我需要生成1000个PPT,并根据同一行中可用的名称保存文件,任何人都可以帮助我解决此查询 我的逻辑是这样的。 循环遍历所有行 创建工作表 为第一行创建图表 在ppt第一张幻灯片中复制粘贴 然后删除工作

我需要通过更新每行可用excel数据(动态行计数)第二张幻灯片中的图表来生成多个powerpoint文件

我有一个excel文件,大约有1000行(每次计数都是动态的),每行都是一个记录,根据1行,我在excel中创建了一个图表,我需要将其复制到现有ppt模板的第二张幻灯片中。因此,通过这种方式,我需要生成1000个PPT,并根据同一行中可用的名称保存文件,任何人都可以帮助我解决此查询

我的逻辑是这样的。 循环遍历所有行 创建工作表 为第一行创建图表 在ppt第一张幻灯片中复制粘贴 然后删除工作簿中的图表或工作表 重复所有步骤直到结束

下面是我之前尝试过的代码,在中,我在ppt中创建了图表,并链接到了数据文件的第一行,但它只解决了我的一半问题,即我只能创建一个报表,不能创建多个报表

Sub Update()
Dim CName, pth
pth = ThisWorkbook.Path
Dim pptPres As PowerPoint.Presentation
Dim pptApp As PowerPoint.Application
Dim Sld As PowerPoint.Slide
Dim sh As PowerPoint.Shape
Dim wb As Workbook
Dim aLinks As Variant
Dim FName  As String
Dim strPptTemplatePath As String


strPptTemplatePath = "C:\Users\DSS1080\Desktop\Business continuity planning\Report Template.pptx"

Application.ScreenUpdating = False
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = msoTrue
Set pptPres = pptApp.Presentations.Open(strPptTemplatePath, untitled:=msoTrue)
NewLink = pth & "\" & ThisWorkbook.Name
pptApp.Activate
For Each Sld In pptPres.Slides
    For Each sh In Sld.Shapes
    If sh.Type = msoChart Then
                 sh.Chart.ChartData.Activate
                 Set wb = sh.Chart.ChartData.Workbook
                 aLinks = wb.LinkSources(xlExcelLinks)
                    wb.Sheets(1).Cells(100, 100).Value = aLinks
                    Oldfile = Cells(100, 100).Value
                    wb.ChangeLink Name:=Oldfile, NewName:=NewLink, Type:=xlExcelLinks
                    wb.Sheets(1).Cells(100, 100).Clear
                wb.Close False
                 Set wb = Nothing
                 sh.Chart.ChartData.Activate
                 Set wb = sh.Chart.ChartData.Workbook
                 wb.Close False
                 Set wb = Nothing
    End If
Next
Next

FName = Sheets("Quadrant").Range("C1").Text
CName = Left(strPptTemplatePath, Len(strPptTemplatePath) - 19) & FName
pptPres.SaveAs CName, ppSaveAsDefault
pptPres.Close
Set pptPres = Nothing
pptApp.Quit
Set pptApp = Nothing
Application.ScreenUpdating = True

End Sub

请添加excel数据的屏幕截图。此外,您是否正在尝试创建多个ppt文件并将图表导出到每个文件的第二张幻灯片,或者您是否正在尝试创建一个ppt文件并从同一文件中的secod文件开始导出图表。请添加excel数据的屏幕截图。此外,您是否正在尝试创建多个ppt文件并将图表导出到每个文件的第二张幻灯片,或者尝试创建一个ppt文件并从同一文件中的secod文件开始导出图表。