Question

我想将excel表中的一系列列复制到现有的PowerPoint表中。

这是我使用的代码，并尝试根据我的需要进行修改，但它不起作用。代码将表复制到PP但保留excel格式。

`Sub PasteMultipleSlides()

'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(2, 3)

'List of Excel Ranges to Copy from
    MyRangeArray = Array(Sheets("Tabelle1").Range("Tabelle1[#All]"), Sheets("Tabelle6").Range("Tabelle14[#All]"))

'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.PasteSpecial(DataType:=2) 'Excel 2007-2010
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
      On Error GoTo 0

    'Center Object
      With myPresentation.PageSetup
        shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
        shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
      End With

  Next x

'Transfer Complete
  Application.CutCopyMode = False
  ThisWorkbook.Activate
  MsgBox "Complete!"

End Sub

这些是我想要复制到PP中幻灯片2上的表的列：

Sheets("Tabelle6")
    Range("Tabelle14[[company ]]").Select
    Range("Tabelle14[customer number]").Select
    Range("Tabelle14[order number]").Select
    Range("Tabelle14[order value]").Select

这些是我想要复制到PP幻灯片3中的表格的列：

Sheets("Tabelle1")
    Range("Tabelle1[[company ]]").Select
    Range("Tabelle1[customer number]").Select
    Range("Tabelle1[order number]").Select
    Range("Tabelle1[order value]").Select

我希望你能帮助我！谢谢！

Answer 1

当谈到将数据从Excel引入Powerpoint时，您需要遍历所有单元格，正如dwirony所解释的那样。但是，您可以通过（例如）

来处理Excel表格列范围，而不是仅在Excel范围内工作

activesheet.listobjects(i).listcolumns(j).range

简化此任务的一个好处是在Excel中准备Powerpoint表数据，使您拥有一种暂存区域。这可能是您的表旁边的范围，其中仅包含Powerpoint的所需列（公式将是简单引用，例如＆＃34; = A3＆＃34;）。然后你可以应用一个更简单的VBA算法，因为它只是Excel范围到整个Powerpoint表，而不考虑列映射）

如果您希望在没有编码的情况下使其更舒适，您还可以尝试SlideFab（https://slidefab.com），它可以将Excel表格链接到Powerpoint并自动更新数据。免责声明：这是我的软件。

干杯

延

使用VBA将范围从Excel复制到现有PowerPoint表

1 个答案: