Export XLS vers ppt : découper automatiquement le tableau selon la largeur du slide

[SimoB]

Bonjour à tous,

J'ai besoin d'exporter un tableau Excel de 200 lignes vers Power Point.
Mon besoin est d'avoir ce tableau sur plusieurs slides pour une lecture plus confortable de chaque contenu de lignes. Il faut donc "découper" mon tableau.
Le problème est que je voudrais découper ce tableau d'une manière dynamique : prendre autant de lignes que possible tant que cela rentre sur un slide power point sans souci, sinon passer sur un autre slide.
(D'un cas à un autre, les lignes peuvent avoir une largeur différente).

Le code suivant que j'ai pu tester permet de faire un découpage " prédéfini" et ne correspond pas donc tout à fait à mon besoin.

Pouvez-vous m'aider svp ?

Merci,

________

Sub ExcelRangeToPowerPoint()

Dim rng1 As Excel.Range
Dim rng2 As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim mySlide2 As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape

'Copy Range from Excel
Set rng1 = ThisWorkbook.ActiveSheet.Range("A4:J14")
Set rng2 = ThisWorkbook.ActiveSheet.Range("A15:J29")

'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

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

'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
rng1.Copy

Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)

myShapeRange.Left = 40
myShapeRange.Top = 150


rng2.Copy
Set mySlide2 = myPresentation.Slides.Add(2, ppLayoutTitleOnly)
mySlide2.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShapeRange2 = mySlide2.Shapes(mySlide.Shapes.Count)

myShapeRange2.Left = 40
myShapeRange2.Top = 150


'Clear The Clipboard
Application.CutCopyMode = False

End Sub