如何在 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