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

我希望宏自动输入给定文件 - ＆gt;表 - ＆gt;获取幻灯片的范围，将其复制并粘贴为演示文稿的图片，并为其提供相应的标题，然后循环到下一行并执行相同的操作。

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

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对象。与工作表是一样的。你完全用同样的方式提到：

Dim ws as Worksheet
Set ws = ActiveSheet

现在 ws 被引用到活动表格，您可以从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

真的很感谢你的回答我不得不使用＆＃34; ThisWorkbook.Activate＆＃34;在一些地方。现在这个宏工作几乎完美..这意味着创建幻灯片的顺序是相反的：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

从几个Excel文件到PowerPoint

2 个答案: