如何在PowerPoint幻灯片上放置Excel范围？

Question

我将以下代码修改为我的要求，但幻灯片定位除外。它将范围放置在每张幻灯片的不同位置。

我正在尝试将对象放置在距幻灯片左侧和幻灯片顶部一定距离的位置。

Sub copiSylwadau()

'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: www.TheSpreadsheetGuru.com

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

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

'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(5, 7, 9, 11, 13, 15, 17, 18, 20, 22, 24, 26, 27, 28, 31)

'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet4.Range("A1:A12"), Sheet9.Range("A1:A12"), Sheet10.Range("A1:A12"), Sheet11.Range("A1:A12"), Sheet12.Range("A1:A12"), Sheet13.Range("A1:A12"), Sheet14.Range("A1:A12"), Sheet15.Range("A1:A12"), Sheet16.Range("A1:A12"), Sheet17.Range("A1:A12"), Sheet18.Range("A1:A12"), Sheet19.Range("A1:A12"), Sheet20.Range("A1:A12"), Sheet21.Range("A1:A12"), Sheet22.Range("A1:A12"))

'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.Paste
    Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange
    On Error GoTo 0

    'Center Object
    With myPresentation.PageSetup
        shp.Left = 20
        shp.Top = 40
        shp.Width = 679
    End With
Next x

'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Cyflwyniad PowerPoint wedi eu greu!"

End Sub

[另外，我尝试了多种方法来设置要复制的范围内文本的字体和大小。例如，尝试在myPresentation.PageSetup命令下方添加代码，该代码未被识别。

Shp.TextRange.Font.Size = 14
Shp.TextRange.Font.Name = "Arial"

Answer 1

由于您只是将范围从Excel粘贴到Powerpoint，因此将其粘贴为表格，因此需要进行格式化。

     Dim lRow As Long
     Dim lCol As Long
     Dim oTbl As Table

        Set oTbl = shp.Table
            For lRow = 1 To oTbl.Rows.Count
                For lCol = 1 To oTbl.Columns.Count
                    With oTbl.Cell(lRow, lCol).Shape.TextFrame.TextRange
                        .Font.Name = "Arial"
                        .Font.Size = 14
                    End With
                Next
            Next

Answer 2

尝试这样：PageSetup设置幻灯片大小，而不是图形在幻灯片上的位置；您无需为此烦恼。

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

  'Center Object
    shp.Left = 20
    shp.Top = 40
    shp.Width = 679