vba - 将范围从 Excel 粘贴到 PowerPoint，同时保持格式设置

Question

我正在尝试从 Excel 报告自动生成 PowerPoint 演示文稿。我以前手动完成了这个，没有问题。

当我从 Excel 复制一个范围时，我会将其粘贴到 PowerPoint 中，然后从选项中选择保留源格式。然后，我会将表格调整为我希望它在幻灯片上显示的方式，并在必要时更改字体大小。

在 VBA 中执行此操作，我找不到粘贴表格的等效方法。

设置好我的工作簿和 PowerPoint，并很好地复制了我的范围后，我用它来粘贴表格。

Slide2.Shapes.PasteSpecial ppPasteEnhancedMetafile

我也试过

Slide2.Shapes.PasteSpecial ppPasteOLEObject

两者都可以粘贴表格，但是一旦我调整形状大小，文本都会扭曲，并且我无法编辑文本大小，这与手动粘贴时不同。

我应该使用什么方法来保留通过手动执行此操作获得的功能？我并不特别需要链接回 Excel 的表格，它可以只是 PowerPoint 中的文本表格。

任何指导将不胜感激，谢谢。

有关信息，我使用的是 Office 2010。

这是我的完整代码..

'Define public variables
  'PowerPoint variables
  Public PPApp As PowerPoint.Application
  Public PPPres As PowerPoint.Presentation

  'Data variables
  Public YYYY   As String
  Public YYMM   As String
  Public MonYy7 As String
  Public Mth    As String
  Public Qtr    As String

  'Location variables
  Public rptPath As String

Public Function GetLayout(LayoutName As String, _
                          Optional ParentPresentation As Presentation = Nothing) As CustomLayout

 If ParentPresentation Is Nothing Then
  Set ParentPresentation = PPPres
 End If

 Dim oLayout As CustomLayout
 For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
  If oLayout.Name = LayoutName Then
   Set GetLayout = oLayout
   Exit For
  End If
 Next
End Function

Sub Dates()
 Dim MthEnd As Date
 MthEnd = DateSerial(Year(Date), Month(Date), 0)

 YYYY = Format(MthEnd, "YYYY")
 YYMM = Format(MthEnd, "YYMM")
 MonYy7 = Format(MthEnd, "MMMM YYYY")
 Mth = Format(MthEnd, "MMM")

 'Quarter
 Quarter = Round(Month(MthEnd) / 3, 0)
 If Quarter = 1 Then
  Qtr = "Q" & Quarter & " " & YYYY
 ElseIf Quarter = 2 Then
  Qtr = "H1 " & YYYY
 ElseIf Quarter = 3 Then
  Qtr = "Q" & Quarter & " " & YYYY
 End If
End Sub

Sub Produce_Pack()
 'Setup dates
 Call Dates

 'Setup reference to the ARA workbook
 Dim wb As Workbook
 Set wb = ThisWorkbook

 'Setup reference to worksheet range
 Dim rng As Range

 'Setup reference to the worksheet
 Dim ws As Worksheet
 Set ws = wb.Worksheets("Pack Source Tables")

 'Setup reference to PowerPoint shape
 Dim pShape As PowerPoint.Shape

 'Open PowerPoint
 Set PPApp = CreateObject("PowerPoint.Application")

 'Create a new presentation
 Set PPPres = PPApp.Presentations.Add
 Application.Wait (Now + TimeValue("0:00:05"))

 'Set presentation slide references
 Dim oSlides As Slides
 Dim oSlide As Slide

 Set oSlides = PPPres.Slides

 'Set slide dimensions
  'Conversion of CMs to Points is * 28.34646
  PPPres.PageSetup.SlideHeight = 21# * 28.34646
  PPPres.PageSetup.SlideWidth = 29.7 * 28.34646

 'Apply the Risk template
 PPPres.ApplyTemplate ("C:\Template.potx")

 'Text variable
 Dim txt As String

 'Slide 1
   'Create slide
   Dim Slide1 As PowerPoint.Slide
   Set Slide1 = PPPres.Slides.Add(1, ppLayoutCustom) 'Default front cover

   'Text 1
   If Mth = "Dec" Then
    txt = "Title 1" & YYYY
   Else
    txt = "Sub Title" & vbNewLine & Qtr
   End If

   Slide1.Shapes("Title 1").TextFrame.TextRange.Text = txt

   'Text 2
   txt = "Sub Title 2"

   Slide1.Shapes("Text Placeholder 2").TextFrame.TextRange.Text = txt

   'Text 3
   txt = MonYy7

   Slide1.Shapes("Text Placeholder 3").TextFrame.TextRange.Text = txt

 'Slide 2
   'Create slide
    Set oSlide = oSlides.AddSlide(oSlides.Count + 1, GetLayout("Slide Layout 5"))

    Dim Slide2 As PowerPoint.Slide
    Set Slide2 = oSlide

    Slide2.Shapes("Content Placeholder 1").Delete

    'Title text
    txt = "Annual Report & Accounts (ARA)"
    Slide2.Shapes("Title 1").TextFrame.TextRange.Text = txt

    'Copy tables from Excel
    Set rng = ws.Range("A:A")

    rng.ColumnWidth = 22.75

    Set rng = ws.Range("A4:C27")

    'Copy the table range
    Application.CutCopyMode = False
    rng.Copy
    Application.Wait (Now + TimeValue("0:00:02"))

    'Paste the table in to the slide
    Slide2.Shapes.PasteSpecial ppPasteOLEObject

    'Name the new shape object
    Set pShape = Slide2.Shapes(Slide2.Shapes.Count)
    pShape.Name = "Slide_2_Table_1"
    pShape.LockAspectRatio = False

    'Set the position and size of the new shape.
     'Conversion of CMs to Points is * 28.34646
     pShape.Left = 1.3 * 28.34646
     pShape.Top = 5.64 * 28.34646
     pShape.Height = 13.66 * 28.34646
     pShape.Width = 22.75 * 28.34646

End Sub

Answer 1

问题是您粘贴的是图像，因此无法进行拉伸(stretch)、着色或字体大小更改。

您需要做的是将粘贴为普通表格，然后您可以使用该格式。

下面是从您的代码中提取的完美运行的代码，您可以在 PowerPoint 中粘贴的表格中进行更改。

将代码粘贴到 Excel VBA 开发人员中。

在excel中，输入一些内容，如下图示例



然后在 excel VBA 中更新此代码并执行它

    'Define public variables

  'Data variables
  Dim YYYY   As String
  Dim YYMM   As String
  Dim MonYy7 As String
  Dim Mth    As String
  Dim Qtr    As String

  'Location variables
  Dim rptPath As String

Sub Dates()
 Dim MthEnd As Date
 MthEnd = DateSerial(Year(Date), Month(Date), 0)

 YYYY = Format(MthEnd, "YYYY")
 YYMM = Format(MthEnd, "YYMM")
 MonYy7 = Format(MthEnd, "MMMM YYYY")
 Mth = Format(MthEnd, "MMM")

 'Quarter
 Quarter = Round(Month(MthEnd) / 3, 0)
 If Quarter = 1 Then
  Qtr = "Q" & Quarter & " " & YYYY
 ElseIf Quarter = 2 Then
  Qtr = "H1 " & YYYY
 ElseIf Quarter = 3 Then
  Qtr = "Q" & Quarter & " " & YYYY
 End If
End Sub

Sub Produce_Pack()

  Dim PPApp As PowerPoint.Application
  Dim PPPres As PowerPoint.Presentation


 'Setup dates
 Call Dates

 'Setup reference to the ARA workbook
 Dim wb As Workbook
 Set wb = ThisWorkbook

 'Setup reference to worksheet range
 Dim rng As Range

 'Setup reference to the worksheet
 Dim ws As Worksheet
 Set ws = wb.Worksheets("Sheet1")

 'Setup reference to PowerPoint shape
 Dim pShape As PowerPoint.Shape

 'Open PowerPoint
 Set PPApp = CreateObject("PowerPoint.Application")

 'Create a new presentation
 Set PPPres = PPApp.Presentations.Add
 'Application.Wait (Now + TimeValue("0:00:05"))

 'Set presentation slide references
 Dim oSlides As Slides
 Dim oSlide As Slide

 Set oSlides = PPPres.Slides

 'Set slide dimensions
  'Conversion of CMs to Points is * 28.34646
  'PPPres.PageSetup.SlideHeight = 21# * 28.34646
  'PPPres.PageSetup.SlideWidth = 29.7 * 28.34646

 'Apply the Risk template
 'PPPres.ApplyTemplate ("C:\Template.potx")

 'Text variable
 Dim txt As String

 'Slide 1
   'Create slide
   Dim Slide1 As PowerPoint.Slide
   Set Slide1 = PPPres.Slides.Add(1, pplayoutcustom) 'Default front cover

   'Text 1
   If Mth = "Dec" Then
    txt = "Title 1" & YYYY
   Else
    txt = "Sub Title" & vbNewLine & Qtr
   End If

   Slide1.Shapes("Title 1").TextFrame.TextRange.Text = txt


    'Copy tables from Excel
    Set rng = ws.Range("A:A")

    rng.ColumnWidth = 22.75

    Set rng = ws.Range("A1:C15")

    'Copy the table range
    Application.CutCopyMode = False
    rng.Copy
    'Application.Wait (Now + TimeValue("0:00:02"))

    'Paste the table in to the slide
    Slide1.Shapes.PasteSpecial ppPasteHTML, msoFalse  '<---- the actual change

    'Name the new shape object
    Set pShape = Slide1.Shapes(Slide1.Shapes.Count)
    pShape.Name = "Slide_1_Table_1"
    pShape.LockAspectRatio = False

    'Set the position and size of the new shape.
     'Conversion of CMs to Points is * 28.34646
     pShape.Left = 1.3 * 28.34646
     pShape.Top = 5.64 * 28.34646
     pShape.Height = 13.66 * 28.34646
     pShape.Width = 22.75 * 28.34646

End Sub

指向的箭头是唯一的变化，我让代码更快地为我工作并注释掉其余部分

休息一下，您可以使用代码，它会起作用。

希望这是您正在寻找的答案

干杯