从几个 Excel 文件到 PowerPoint

Question

我是 VBA 编程的新手。但是我必须（并且想要）在 Excel 文件中创建宏来自动创建 PowerPoint 演示文稿。

我希望有人能够帮助我或遇到类似的问题。 即 - 我在 Excel 文件中有 6 列：

1 - slide number
2 - file access path
3 - file name
4 - sheet name
5 - slide range
6 - slide title

我希望宏自动输入给定文件->工作表->获取幻灯片的范围，将其复制并粘贴为演示文稿的图片，并为其赋予适当的标题，然后循环到下一行，然后做同样的事情。

有人可以帮助我吗？下面是我设法编写的代码，但是，我不知道如何从给定单元格中引用工作表和幻灯片的范围。

Option Explicit

Sub ExcelRangeToPowerPoint()
     Dim rng As Range
     Dim PowerPointApp As Object
     Dim myPresentation As Object
     Dim mySlide As Object
     Dim myShape As Object
     Dim adr1 As String
     Dim shta As Worksheet
     Dim wrk As String

     Application.DisplayAlerts = False

     wrk = ThisWorkbook.Name ' nname
     adr1 = Worksheets("Sheet1").Range("B2")

    'Copy Range from Excel
    ' Set rng = ThisWorkbook.ActiveSheet.Range("A1:C12")

    '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 open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

    '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

    'Optimize Code
      Application.ScreenUpdating = False

     'Create a New Presentation
      Set myPresentation = PowerPointApp.Presentations.Add

      ThisWorkbook.Activate
      Range("A2").Select
     'DO While
      Do While ActiveCell.Value <> ""
          Workbooks.Open Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True ' to be sure read-only open
          ' Worksheet Open from D2
          'Copy Range from E2

          'Add a slide to the Presentation
          Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
          'Paste to PowerPoint and position
          mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile + title from F2
          Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

          ActiveWorkbook.Close SaveChanges:=False  ' close file and don't save
          ActiveCell.Offset(1, 0).Range("A1").Select
      Loop

      MsgBox ("Ready")
      Application.CutCopyMode = False
      Application.DisplayAlerts = True
End Sub

Answer 1

您总是可以参考一些工作表或工作簿创建第一个变量类型工作簿或工作表。

如果您想将变量引用到工作表/工作簿，这很容易。只是一套。比如：

Dim wb as Workbook
Set wb = ThisWorkbook

现在 wb 将被引用到 ThisWorkbook 对象。与 Worksheets 相同。您的引用方式完全相同：

Dim ws as Worksheet
Set ws = ActiveSheet

现在ws被引用到activesheet，你可以从ws处理它。

我希望这能回答您的一些疑问。关于你的代码，循环部分应该是这样的：

Dim MyWb As Workbook 'variable for workbook
Dim MyWs As Worksheet 'variable for worksheet

ThisWorkbook.Activate
Range("A2").Select
'DO While
Do While ActiveCell.Value <> ""
    ThisWorkook.Activate
    Set MyWb = Workbooks.Open(Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True) ' to be sure read-only open
    ' Worksheet Open from D2

    Set MyWs = MyWb.Worksheets(ActiveCell.Offset(0, 3).Value) 'now MyWs is referenced to the worksheet in column D

    'Copy Range from E2
    MyWs.Activate
    MyWs.Range(ActiveCell.Offset(0, 4).Value).Copy 'we copy the range shown in column E


    'Add a slide to the Presentation
    Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile + title from F2
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

    'after pasting, we go back to active workbook
    Application.CutCopyMode = False
    MyWb.Activate

    MyWb.Close SaveChanges:=False  ' close file and don't save
    Set MyWs = Nothing
    Set MyWb = Nothing
    ActiveCell.Offset(1, 0).Select 'we go 1 row down
Loop

我希望你可以测试它并告诉我它是否有助于你说清楚:)

Answer 2

非常感谢您的回答 我不得不在几个地方使用“ThisWorkbook.Activate”。 现在这个宏工作几乎完美了..这意味着创建幻灯片的顺序是相反的：1是最后一个，最后一个是1.. 更重要的是，我还想从 Excel 文件列 F 中创建每张幻灯片的标题。

在我的 VBA 代码下方：

Sub VBA_PowerPoint()

Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim MyWb As Workbook 'variable for workbook
Dim MyWs As Worksheet 'variable for worksheet
Dim MyRg As Excel.Range ' variable for Range

Application.DisplayAlerts = False

ThisWorkbook.Activate
Range("A2").Select

'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 open PowerPoint
  If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

 '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

 'Optimize Code
  Application.ScreenUpdating = False

 'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add


 'Do While
 ThisWorkbook.Activate

Do While ActiveCell.Value <> ""
 ThisWorkbook.Activate
 Set MyWb = Workbooks.Open(Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True) ' to be sure read-only open
 ' Worksheet Open from D2
 ThisWorkbook.Activate
 Set MyWs = MyWb.Worksheets(ActiveCell.Offset(0, 3).Value) 'now MyWs is referenced to the worksheet in column D

 'Copy Range from E2
' Set MyRg = MyWs.Range(ActiveCell.Offset(0, 4).Value) 'now MyWs is referenced to the worksheet in column E

' MyWs.Range(MyRg).Copy 'we copy the range shown in column E
 ThisWorkbook.Activate
 MyWs.Range(ActiveCell.Offset(0, 4).Value).Copy


 'Add a slide to the Presentation
 Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
 'Paste to PowerPoint and position
 mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile + title from F2
 Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

 'after pasting, we go back to active workbook
  Application.CutCopyMode = False
  MyWb.Activate

  MyWb.Close SaveChanges:=False  ' close file and don't save
  Set MyWs = Nothing
  Set MyWb = Nothing
  ActiveCell.Offset(1, 0).Select 'we go 1 row down
Loop


Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub