Insérer plusieurs parties d'un excel vers PWP
Vouxy_90
-
f894009 Messages postés 17277 Date d'inscription Statut Membre Dernière intervention -
f894009 Messages postés 17277 Date d'inscription Statut Membre Dernière intervention -
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
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
A voir également:
- Insérer plusieurs parties d'un excel vers PWP
- Insérer liste déroulante excel - Guide
- Insérer video powerpoint - Guide
- Formule moyenne excel plusieurs colonnes - Guide
- Insérer signature word - Guide
- Word et excel gratuit - Guide
1 réponse
Bonjour,
code modifie pour E/S en trois parties. A vous de positionner les Shapes
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