run-time error '-2147417851 (80010105)'; Method 'PasteSpecial' ofobejct 'Shapes' failed

[Mieds]

I am trying to create PowerPoint slides from an access database,
basically the data is queried in access, pasted and formatted into
Excel and then copied into PowerPoint. The program loops through
different data (cities) and create a series of slides based on the
results for each city. When I had a small number of cities (35) the
program worked fine, now that I increased the number of cities (160)
the program fails, I get a run-time error '-2147417851 (80010105)';
Method 'PasteSpecial' of obejct 'Shapes' failed

Here is a snippet of the code and where it is failing, after looping
through about 90 times the program fails on the last section,
objPPTSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Name =
"SummaryTableOne". Any ideas or advice would be greatly appreciated.

Option Compare Database

Option Explicit



Sub CreateSlides()

Dim datDate0, datDate1, datDate2, datDate3 As Date

Dim intCurrentSheet, intDMACount, intStartCopy, intEndCopy As
Integer

Dim db As DAO.Database

DoCmd.SetWarnings False

gstrPath = "C:\USER\Data\"

'Create Application Variables

'*Excel

Dim xlApp As Excel.Application

Dim xlWorkbookC As Excel.Workbook

Dim xlWorkbookTemp As Excel.Workbook

Dim xlSheetSlide0, xlSheetSlide1, xlSheetSlide2, xlSheetSlide2U,
xlSheetSlide3, xlSheetSlideTemp As Excel.Worksheet

'*Powerpoint

Dim objPPTApp As PowerPoint.Application

Dim objPPTPresen As PowerPoint.Presentation

Dim objPPTSlide As PowerPoint.Slide

Dim objPPTShape As PowerPoint.Shape



'Open Excel Application

Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True

Set xlWorkbookC = xlApp.Workbooks.Open(gstrPath &
"DMATemplate.xlsm")

Set xlSheetSlide0 = xlWorkbookC.Sheets("Page_01")

Set xlSheetSlide1 = xlWorkbookC.Sheets("Slides")

Set xlSheetSlide2 = xlWorkbookC.Sheets("Slide2A")

Set xlSheetSlide2U = xlWorkbookC.Sheets("Slide2B")

Set xlSheetSlide3 = xlWorkbookC.Sheets("Page_99")

'Open Powerpoint Application

Set objPPTApp = CreateObject("Powerpoint.Application")

objPPTApp.Visible = True

Set objPPTPresen = objPPTApp.Presentations.Open(gstrPath &
"Template.pptm")

With objPPTPresen.Slides

Set objPPTSlide = .Item(1)

End With



'Create Slide 1

With objPPTPresen.Slides

s = objPPTPresen.Slides.Count

Set objPPTSlide = .Add(s, ppLayoutBlank)

End With

'Create Slide1

Set objPPTShape =
objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _

Left:=18, Top:=18, Width:=600, Height:=50)

With objPPTShape

.TextFrame.TextRange.Font.Name = "Verdana"

.TextFrame.TextRange.Font.Bold = msoTrue

.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft

.TextFrame.TextRange.Text = "Advance 12M Sales Growth vs.
Remaining Market"

.TextFrame.TextRange.Lines(1).Font.Size = 18

End With



With objPPTPresen.Slides

s = objPPTPresen.Slides.Count

Set objPPTSlide = .Add(s, ppLayoutBlank)

End With



Set objPPTShape =
objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _

Left:=18, Top:=18, Width:=600, Height:=50)

With objPPTShape

.TextFrame.TextRange.Font.Name = "Verdana"

.TextFrame.TextRange.Font.Bold = msoTrue

.TextFrame.TextRange.ParagraphFormat.Alignment =
ppAlignLeft

.TextFrame.TextRange.Text = "Advance 12M Sales Growth vs.
Remaining Market"

.TextFrame.TextRange.Lines(1).Font.Size = 18

End With



xlSheetSlide0.Select

xlSheetSlide0.Range(strCopyRange).Copy



objPPTSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Name
= "SummaryTableOne"

With objPPTShape

.ScaleHeight 0.4, msoTrue, msoScaleFromMiddle

.ScaleWidth 0.8, msoTrue, msoScaleFromMiddle

.Top = 75

.Left = 18

End With