VBA - 粘贴具有相同尺寸的表格/形状

Question

我正在尝试创建一个脚本，该脚本在excel中使用长表并将其拆分为PowerPoint中的不同幻灯片。

下面的脚本适用于创建powerpoint，（如果你想尝试一下，只需将它粘贴到一个excel中，其值为“Sheet1”和“Sheet2”。但是，将要粘贴表格的脚本） Sheet2不能在所有幻灯片上以相同的尺寸通过表格.Pheet输出将具有不同的宽度和高度，并放置在幻灯片上的不同位置（即使我已经指定了这一点）。

有什么问题？我想保留excel中指定的布局，并在PowerPoint中对齐表格。

对于凌乱的代码很抱歉，我还在学习（excelguru的大部分代码）。这是脚本的第一部分，用于读取（并粘贴excel数据）：

Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object


Sub Export_To_PPT()
 Dim slideNumber As Integer
 Dim rng As Range
 Dim myShape As Object
 slideNumber = 1

'Copy Range from Excel
Set rng = ThisWorkbook.Sheets("Sheet1").Range("B2:I27")

'Create an Instance of PowerPoint
On Error Resume Next

ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.pptx), *.pptx")
Set PowerPointApp = CreateObject("Powerpoint.Application")
If ActFileName = False Then
    PowerPointApp.Activate
    PowerPointApp.Presentations.Add
    Set myPresentation = PowerPointApp.Presentations.Add
Else
    PowerPointApp.Activate
    Set myPresentation = PowerPointApp.Presentations.Open(ActFileName)
End If


On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False

'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(slideNumber, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
rng.Copy

'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=0  '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

' Set dimensions
myShape.Width = 721
myShape.Height = 414
'Set position:
myShape.Left = -40
myShape.Top = 83

slideNumber = Export_To_Risk_Table(slideNumber)

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

'Clear The Clipboard
Application.CutCopyMode = False
End Sub

Function Export_To_Risk_Table(slideNumber As Integer)
 slideNumber = slideNumber + 1

 Dim rng As Range
 Dim heightCount As Integer
 Dim heightMax As Integer

 heightMax = 414

 'Copy Range from Excel
 Dim header As Range
 Dim rows As Range
 Dim rowNumber As Integer
 Set header = ThisWorkbook.Sheets("Sheet2").Range("B2:H2")

 rowNumber = 2
 rowNumberReference = 3

 Do While WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet2").Range("B" & rowNumber + 1 & ": H" & rowNumber + 1)) <> 0
  heightCount = ThisWorkbook.Sheets("Sheet2").Range("B2").Height

  Do While heightCount < heightMax And WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet2").Range("B" & rowNumber + 1 & ": H" & rowNumber + 1)) <> 0
   rowNumber = rowNumber + 1
   heightCount = heightCount + ThisWorkbook.Sheets("Sheet2").Range("B" & rowNumber).Height
 Loop

 Set rows = ThisWorkbook.Sheets("Sheet2").Range("B" & rowNumberReference & ":H" & rowNumber)
 Set rng = Union(header, rows)
 Dim rngS As String
slideNumber = pasteSlide("B" & rowNumberReference & ":H" & rowNumber, slideNumber, rowNumber - rowNumberReference)
 rowNumberReference = rowNumber + 1
 Loop

 Export_To_Risk_Table = slideNumber

End Function

这是我认为错误的地方。该部分负责将新数据粘贴到新幻灯片中。它设定了尺寸和位置：

Function pasteSlide(stringRange As String, slideNumber As Integer, difference As Integer)

'Copy Excel Range
 ThisWorkbook.Sheets("Sheet2").Activate
 ThisWorkbook.Sheets("Sheet2").Range(stringRange).Copy
 ThisWorkbook.Sheets("Sheet2").Range("J3").Select
 ThisWorkbook.Sheets("Sheet2").Paste
 ThisWorkbook.Sheets("Sheet2").Range("J2:P" & 2 + difference + 1).Copy

 Set mySlide = myPresentation.Slides.Add(slideNumber, 11) '11 = ppLayoutTitleOnly

 mySlide.Shapes.PasteSpecial DataType:=10
 Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
 ' Set dimensions
 myShape.Width = 719
 myShape.Height = 414

'Set position:
 myShape.Left = 0
 myShape.Top = 83

 ThisWorkbook.Sheets("Sheet2").Range("J3:P" & 3 + difference + 1) = Null
 Application.CutCopyMode = False
 DoEvents

 pasteSlide = slideNumber + 1

End Function

编辑 - 以下是图片

滑动一个简单的信息中心

滑动表格的第二部分。来自我认为正在执行的脚本部分 第三张幻灯片，表格的第二部分。来自我认为正在执行的脚本部分

如您所见，即使我指定了它们的大小和位置，第二张和第三张幻灯片也有不同的尺寸。

以下是您可以用来测试我的脚本的excel和powerpoint的链接：LINK