insérer plusieurs parties d'un excel vers PWP Fermé

Question

Bonjour,

J'aimerais adapter ma macro qui actuellement génère un powerpoint et affiche un tableau issu de excel.
L'idée est la suivante:
- Le tableau que j'importe dans PWP via la macro se situe entre la cellule A1 et Z30. J'aimerai pouvoir importer uniquement 2 ou 3 partie de ce tableau. 
Par exemple: importer via la macro dans une diapo pwp la partie de tableau de A1 jusque D30 puis juste à côté rajouter J1 jusque M30 et enfin encore juste à côté la aprtie de tableau de Q1 jusque T30. 

Je vous mets ci-dessous le code que j'ai pour le moment et qui fonctionne pour intégrer un tableau complet en une fois. 
Dans la partie 'STORE ID', vous pouvez voir --> .Range("E30:S56") qui est le fameux tableau que j'importe en entier. J'aimerais donc importer plusieur partie différentes de ce tableau pour créer ma présentation powerpoint.

Est-ce que quelqu'un sait m'aider?

Merci merci!! 



Sub District02_Create_Powerpoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim mySheet As Object
Dim sPath As String
Dim store_district  As String

'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False

'Open Powerpoint file

Set myPresentation = PowerPointApp.Presentations.Open(Filename:="H:\OSS_Shared\BPM-Retail\District Business Review\District_Business Review_Template_file.pptx")
       

' STORE ID

'Copy Range from Excel
  Set rng = ThisWorkbook.Worksheets("STORE ID").Range("E30:S56")

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
Set mySlide = myPresentation.Slides(5)
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
 'Set size:
      myShape.Width = 650
      
 'Set position:
    sngDefaultSlideWidth = myPresentation.PageSetup.SlideWidth
    sngDefaultSlideHeight = myPresentation.PageSetup.SlideHeight
    myShape.Left = (sngDefaultSlideWidth - myShape.Width) / 2
   '   myShape.Left = 40
    myShape.Top = 100

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False
  
  
' GENERAL DASHBOARD

'Copy Range from Excel
  Set rng = ThisWorkbook.Worksheets("HIGHLIGHTS - DASHBOARD").Range("D43:S70")

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
Set mySlide = myPresentation.Slides(6)
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
 'Set size:
      myShape.Width = 610
      
 'Set position:
    sngDefaultSlideWidth = myPresentation.PageSetup.SlideWidth
    sngDefaultSlideHeight = myPresentation.PageSetup.SlideHeight
    myShape.Left = (sngDefaultSlideWidth - myShape.Width) / 2
   '   myShape.Left = 40
    myShape.Top = 100

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False

f894009 · Answer

Bonjour,

code modifie pour E/S en trois parties. A vous de positionner les Shapes

Sub District02_Create_Powerpoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'-----------15/07/2018 --------------------
Dim rng(3) As Range
Dim rngx As Range
'-----------15/07/2018 --------------------
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim mySheet As Object
Dim sPath As String
Dim store_district As String

'Create an Instance of PowerPoint
On Error Resume Next

'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If

On Error GoTo 0

'Optimize Code
Application.ScreenUpdating = False

'Open Powerpoint file

Set myPresentation = PowerPointApp.Presentations.Open(Filename:="H:\OSS_Shared\BPM-Retail\District Business Review\District_Business Review_Template_file.pptx")

' STORE ID
'-------------------------15/07/2018-----------------------
'Copy Range from Excel
Set rng(1) = ThisWorkbook.Worksheets("STORE ID").Range("E30:I56")
Set rng(2) = ThisWorkbook.Worksheets("STORE ID").Range("J30:N56")
Set rng(3) = ThisWorkbook.Worksheets("STORE ID").Range("O30:S56")

'Copy Excel Range en 3 parties
For x = 1 To 3
    rng(x).Copy
    'Paste to PowerPoint and position
    Set mySlide = myPresentation.Slides(1)
    mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    'Set size:
    myShape.Width = 650
    'Set position:
    sngDefaultSlideWidth = myPresentation.PageSetup.SlideWidth
    sngDefaultSlideHeight = myPresentation.PageSetup.SlideHeight
    myShape.Left = (sngDefaultSlideWidth - myShape.Width) / 2
    ' myShape.Left = 40
    myShape.Top = 100

'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate

'Clear The Clipboard
    Application.CutCopyMode = False
Next x
'-------------------------------15/07/2018----------------------------------------------
' GENERAL DASHBOARD

'Copy Range from Excel
Set rngx = ThisWorkbook.Worksheets("HIGHLIGHTS - DASHBOARD").Range("D43:S70")

'Copy Excel Range
rngx.Copy

'Paste to PowerPoint and position
Set mySlide = myPresentation.Slides(6)
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set size:
myShape.Width = 610

'Set position:
sngDefaultSlideWidth = myPresentation.PageSetup.SlideWidth
sngDefaultSlideHeight = myPresentation.PageSetup.SlideHeight
myShape.Left = (sngDefaultSlideWidth - myShape.Width) / 2
' myShape.Left = 40
myShape.Top = 100

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate

'Clear The Clipboard
Application.CutCopyMode = False
End Sub

Insérer plusieurs parties d'un excel vers PWP

1 réponse

Discussions similaires