Generate multiple powerpoint files by updating chart - excel

Question

I need to generate multiple powerpoint files by updating chart in 2nd slide on excel data available in each row(dynamic row counts)
I have a excel file with around 1000 rows(count is dynamic every time) and each row is a record, based on 1 row i have created a chart in excel itself which i need to copy in second slide of my existing ppt template. So in this way i need to generate 1000 ppts and save the files based on the name available in same row, can any one help me to resolve this query.
My logic is something like this.
Loop through all the rows
Create sheet
Create chart for first row
Copy paste in ppt fist slide
Then delete the chart or sheet in workbook
Repeat all the step till the end
Below is the code which i tried earlier where in i have created the chart in ppt and linked to the 1st row of my data file, but it only solves half of my problem that i can create only one report not multiple.
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