Вставить таблицы Excel в существующую PowerPoint - проблема с размером шрифта и миниатюрами в PowerPoint

Question

Я совершенно новичок в кодировании VBA и очень хотел бы вашей помощи. Каждый месяц я создаю новые презентации, в которых выставляю несколько таблиц. Я копирую эти таблицы из Excel и вручную вставляю их в существующее слайд-шоу PowerPoint. Затем я выравниваю таблицы и изменяю размер шрифта данных в таблицах на 9.

Я хочу автоматизировать этот процесс. Выполнив поиск в Интернете и добавив код самостоятельно, я написал приведенный ниже код.

Он отлично работает до вставки и выравнивания таблиц на слайдах.

Первый вопрос - какой код мне нужен, чтобы изменить размер шрифта данных на 9.

Во-вторых, после вставки таблиц в PowerPoint таблицы выровнены правильно, но их эскизы (в левой части экрана) показывают, что таблицы неправильно выровнены (например, они отображаются как находящиеся вне скольжения пока их нет). Я поискал в Интернете и обнаружил, что решение этой ошибки заключается в том, что каждый раз, когда я вставляю таблицу, слайд должен быть активным. Но я не знаю, как это сделать.

Кто-нибудь может помочь?

Ниже мой код.

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

Sub PasteMultipleSlides()

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long

'Create an Instance of PowerPoint
  On Error Resume Next

    'Set your destination path for the powerpoint presentation and open the file
        Set PowerPointApp = CreateObject("Powerpoint.application")
        DestinationPPT = ("C:\Users\...")
        PowerPointApp.Presentations.Open (DestinationPPT)

    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then Exit
      If PowerPointApp Is Nothing Then
        MsgBox "PowerPoint Presentation is not open, aborting."
        Exit Sub
      End If

    '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.ActiveWindow.Panes(2).Activate

'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation

'List of PPT Slides to Paste to
  MySlideArray = Array(4, 5, 6, 7, 8)

'List of Excel Ranges to Copy from
    MyRangeArray = Array(Sheet1.Range("B2:M41"), Sheet4.Range("B2:M41"), _
      Sheet3.Range("B2:M41"), Sheet2.Range("B2:M41"), Sheet6.Range("B2:M41"))


'Loop through Array data
  For x = LBound(MySlideArray) To UBound(MySlideArray)
    'Copy Excel Range
        MyRangeArray(x).Copy

    'Paste to PowerPoint and position
      On Error Resume Next
        Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=0) 
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange
      On Error GoTo 0

    'Set the slide active to solve the issue with the ppt thumbnail



    'Align and Resize Object
      With myPresentation.PageSetup
         shp.Left = 28.35 * -6.2
         shp.Top = 28.35 * 2.5
         shp.Width = 31.69 * 28.35
         shp.Height = 15.32 * 28.35
      End With

  Next x

'Transfer Complete
  Application.CutCopyMode = False
  ThisWorkbook.Activate
  MsgBox "Complete!"

End Sub