Copy data from Excel to powerpoint with 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