Copy data from Excel to powerpoint with vba - vba

Question

I have created a code with vba which copy data from excel sheet and paste the same as picture in powerpoint slide, but its not working exactly as per my need.
It should copy data from each worksheets and paste it in a given powerpoint slide worksheet wise. Measn worksheet 1 data should be copied in slide 1 followed by worksheet 2 data in slide 2 and so on and at the end it should save the created ppt file.
But my code is copying and pasting all worksheets data overlaping each other in all the slides of the powerpoint.
Since i am new to vba i am not sure where i am going wrong with the below code:
Sub WorkbooktoPowerPoint()
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim MyTitle As String
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
oSlide.Select
MyRange = "B2:B5"
MyRange1 = "B8:B11"
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select Application.Wait(Now + TimeValue("0:00:1"))
xlwksht.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 65
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400
xlwksht.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 250
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400
Next xlwksht
Next
oPPTApp.Activate
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub

Answer 1

Please give this a shot. The main change is that I removed the For Each loop. You are already looping through the slides of the deck and can use the slide number to reference the Excel worksheet (they are numbered, as well). It was creating a mess, now it runs smoothly.
Sub WorkbooktoPowerPoint()
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
' The following line was added after the OPs follow-up
If i > ActiveWorkbook.Sheets.Count Then Exit For
oSlide.Select
MyRange = "B2:B5"
MyRange1 = "B8:B11"
With ActiveWorkbook.Sheets(i)
.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
With oPPTApp
.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
.ActiveWindow.Selection.ShapeRange.Top = 65
.ActiveWindow.Selection.ShapeRange.Left = 7.2
.ActiveWindow.Selection.ShapeRange.Width = 400
End With
.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
With oPPTApp
.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
.ActiveWindow.Selection.ShapeRange.Top = 250
.ActiveWindow.Selection.ShapeRange.Left = 7.2
.ActiveWindow.Selection.ShapeRange.Width = 400
End With
End With
Next
oPPTApp.Activate
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub