粘贴范围从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

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

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

下面是从您的代码中提取的代码，它可以正常工作，您可以在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

箭头是唯一的更改，我使代码对我而言更快地工作，并注释掉其余部分

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

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

欢呼