Скопируйте большую таблицу Excel в PowerPoint

Question

Я новичок в VBA и столкнулся с несколькими проблемами с моим макросом.

Как это работает:

У меня есть файл Excel с 2 разными макросами: - Один для копирования и вставки в соответствующие листы, 1 таблица из 3 разных файлов - Один для копирования таблицы в каждого листа и вставьте его в назначенное место на 3 различных слайдах PowerPoint

Проблема, с которой я столкнулся с макросами, заключается в следующем: - Макрос для вставки таблицы в слайд Powerpoint не работает в Excel 2010 с ppPasteSpecial HTML (но работает с pastespecialEnhancedMetafile) - макрос не учитывает размер таблицы: если в таблице 20 строк, он будет вставлен в слайд как есть. Я хотел бы добавить функцию для вставки, например, строки 1-5 на первом слайде и строки 6-10 на втором слайде и так далее.

Не могли бы вы мне помочь?

Заранее спасибо.

Option Explicit

Sub transfert_tables_to_ppt()
Dim ppt_Template_Pres As PowerPoint.Presentation, my_Shp As PowerPoint.Shape, my_Sld As PowerPoint.Slide
Dim my_Shp_Rg As PowerPoint.ShapeRange
Dim ppt_App As New PowerPoint.Application
Dim ppt_Template_Path As String
Dim saving_Folder_path As String

Dim my_file As Scripting.File
Dim FSO As New Scripting.FileSystemObject
Dim new_File_Name As String

Dim Lo As ListObject
Dim dico_Shape_values As New Scripting.Dictionary


Dim s As String
Dim i As Integer
Dim v As Variant
Dim Sh As Worksheet, rg As Range, plg As Range


'Initialisation du rapport de traitement
Sh_Main.[Rg_Execution_report].Value = ""
report_Text = "Info: Ex?cution de la Macro de transfert vers PPT"
ppt_Template_Path = Sh_Main.[Rg_Template].Value
saving_Folder_path = Sh_Main.[Rg_Save_file].Value
new_File_Name = Sh_Main.[Rg_New_ppt_Name].Value

Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error GoTo err_handler

'V?rification des chemins
report_Text = "Info: 1. Chemins d'acc?s v?rifi?s"
If Not object_exist(ppt_Template_Path, "FILE") Then
    report_Text = report_Text & vbCrLf & "Error: Le fichier Powerpoint template est absent de ce r?pertoire " & vbCrLf & _
    Chr(34) & ppt_Template_Path & Chr(34)
    Sh_Main.[Rg_Execution_report].Value = report_Text
    Exit Sub
End If

If Not object_exist(saving_Folder_path, "DIRECTORY") Then
    report_Text = report_Text & vbCrLf & "Le r?pertoire de stockage ci-dessous est inexistant/innacessible. " & vbCrLf & _
    Chr(34) & saving_Folder_path & Chr(34)
    Sh_Main.[Rg_Execution_report].Value = report_Text
    Exit Sub
End If

'Copie du template vers la destination de stockage et renommage du fichier
report_Text = report_Text & vbCrLf & "Info: 2. Template PPT r?cup?r? et stock? dnas le dossier " & Chr(34) & saving_Folder_path & Chr(34)
Set FSO = New Scripting.FileSystemObject

'Set my_file = FSO.GetFile(ppt_Template_Path)
FSO.CopyFile ppt_Template_Path, IIf(Right(saving_Folder_path, 1) = "\", saving_Folder_path & _
new_File_Name, saving_Folder_path & "\" & new_File_Name), True
Set my_file = FSO.GetFile(IIf(Right(saving_Folder_path, 1) = "\", saving_Folder_path & _
new_File_Name, saving_Folder_path & "\" & new_File_Name))

report_Text = report_Text & vbCrLf & "Info: 3. Acc?s au fichier PPT " & Chr(34) & my_file.Path & Chr(34)
Set ppt_App = New PowerPoint.Application
Set ppt_Template_Pres = ppt_App.Presentations.Open(my_file.Path, False, , msoFalse)

'Ins?rer le tableau dans le fichier PPT
report_Text = report_Text & vbCrLf & "Info: 4. Insertion des tableaux dans le fichier PPT"
i = 0
For Each Sh In ThisWorkbook.Sheets
    For Each Lo In Sh.ListObjects
        Set dico_Shape_values = New Scripting.Dictionary
        Set dico_Shape_values = get_ppt_Slide_and_Shape_Properties(ppt_Template_Pres, "<" & Lo.Name & ">")

        If dico_Shape_values.Count > 0 Then
            Set my_Sld = dico_Shape_values("SLIDE")
            If Not my_Sld Is Nothing Then
                i = i + 1
                report_Text = report_Text & vbCrLf & "Info: 4." & i & ". Insertion du tableau " & Lo.Name
                Set plg = Lo.Range
                plg.Copy

'                my_Sld.Select
                Set my_Shp_Rg = my_Sld.Shapes.PasteSpecial(ppPasteHTML, msoFalse)

'               Redimenssionnement et repositionnement du tableau
                With my_Shp_Rg
                    .Height = dico_Shape_values("HEIGHT")
                    .Width = dico_Shape_values("WIDTH")
                    .Top = dico_Shape_values("TOP")
                    .Left = dico_Shape_values("LEFT")
                End With
                Application.CutCopyMode = False

            Else
                report_Text = report_Text & vbCrLf & "Error: 4. Le tableau " & Chr(34) & Lo.Name & Chr(34) & " n'a pas pu ?tre transf?r?." & vbCrLf & _
                "Une erreur est survenue lors de l'identification de la slide de destination"
                GoTo Next_Table
            End If
        End If
Next_Table:
    Next Lo
Next Sh

'Cl?ture du PPT
report_Text = report_Text & vbCrLf & "Info: 5. Cl?ture du fichier PPT"
ppt_Template_Pres.Save
ppt_Template_Pres.Close
If ppt_App.Windows.Count = 1 Then ppt_App.Quit
Set ppt_Template_Pres = Nothing

Sh_Main.[Rg_Macro_Status_PPT].Value = 1
On Error GoTo 0

err_handler:
If Err.Description <> "" Then
    report_Text = report_Text & vbCrLf & "Error: " & Err.Description
    Err.Clear
    Sh_Main.[Rg_Macro_Status_PPT].Value = -1
End If
Sh_Main.[Rg_Execution_report].Value = report_Text

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Function object_exist(path_name As String, object_type As String) As Boolean

object_exist = False
Select Case object_type
Case "DIRECTORY"
    If Len(Dir(path_name, vbDirectory)) > 0 Then
        object_exist = True
    End If

Case "FILE"
    If Len(Dir(path_name)) > 0 Then
        object_exist = True
    End If

End Select
End Function

Function get_ppt_Slide_and_Shape_Properties(ppt_Pres As PowerPoint.Presentation, ppt_shp_text_value As String) As Scripting.Dictionary
'Fonction qui r?cup?re la slide sur laquelle doit ?tre introduite le tableau
Dim my_Slide As PowerPoint.Slide
Dim my_Shape As PowerPoint.Shape
Dim my_Text_Frame As PowerPoint.TextFrame
Dim f_Dico As New Scripting.Dictionary

For Each my_Slide In ppt_Pres.Slides
    For Each my_Shape In my_Slide.Shapes
        If my_Shape.HasTextFrame Then
            Set my_Text_Frame = my_Shape.TextFrame
            If my_Text_Frame.TextRange.Text = ppt_shp_text_value Then

                f_Dico.Add "SLIDE", my_Slide
                f_Dico.Add "HEIGHT", my_Shape.Height
                f_Dico.Add "WIDTH", my_Shape.Width
                f_Dico.Add "TOP", my_Shape.Top
                f_Dico.Add "LEFT", my_Shape.Left

                my_Shape.Delete
                Set get_ppt_Slide_and_Shape_Properties = f_Dico
                Exit Function

            End If
        End If
    Next my_Shape
Next my_Slide

Set get_ppt_Slide_and_Shape_Properties = Nothing
End Function