title: Copy data from Excel to powerpoint with vba
body: <p>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.</p>
  
  <p>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.</p>
  
  <p>But my code is copying and pasting all worksheets data overlaping each other in all the slides of the powerpoint.</p>
  
  <p>Since i am new to vba i am not sure where i am going wrong with the below code:</p>
  
  <pre><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
  </code></pre>