从几个 Excel 个文件到 PowerPoint
From a few Excel files to PowerPoint
我是 VBA 编程的新手。但是我必须（并且想要）在 Excel 文件中创建宏以自动创建 PowerPoint 演示文稿。
我希望有人能帮助我或有类似的问题。
即 - 我在 Excel 文件中有 6 列：
1 - slide number
2 - file access path
3 - file name
4 - sheet name
5 - slide range
6 - slide title
我希望宏自动输入给定的文件 -> sheet -> 获取幻灯片的范围，将其复制并粘贴为演示文稿的图片，并为其指定适当的标题并通过循环到下一行并执行相同的操作。
有人能帮帮我吗？下面是我设法编写的代码，但是，我不知道如何从给定的单元格中引用 sheet 和幻灯片的范围。
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
您总是可以参考一些 sheet 或工作簿创建第一个变量类型工作簿或工作sheet。
如果你想将变量引用到 worksheet/workbook，这很容易。只是一套。类似于：
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
我希望你能测试它并告诉我它是否帮助你弄清楚:)
非常感谢您的回答
我不得不在几个地方使用 "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
我是 VBA 编程的新手。但是我必须（并且想要）在 Excel 文件中创建宏以自动创建 PowerPoint 演示文稿。
我希望有人能帮助我或有类似的问题。 即 - 我在 Excel 文件中有 6 列：
1 - slide number
2 - file access path
3 - file name
4 - sheet name
5 - slide range
6 - slide title
我希望宏自动输入给定的文件 -> sheet -> 获取幻灯片的范围，将其复制并粘贴为演示文稿的图片，并为其指定适当的标题并通过循环到下一行并执行相同的操作。
有人能帮帮我吗？下面是我设法编写的代码，但是，我不知道如何从给定的单元格中引用 sheet 和幻灯片的范围。
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
您总是可以参考一些 sheet 或工作簿创建第一个变量类型工作簿或工作sheet。
如果你想将变量引用到 worksheet/workbook，这很容易。只是一套。类似于：
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
我希望你能测试它并告诉我它是否帮助你弄清楚:)
非常感谢您的回答 我不得不在几个地方使用 "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