循环遍历多个命名范围和单元格值以控制各种 PowerPoint 格式参数=答案

【问题标题】：Loop through multiple named ranges and cell values to control various PowerPoint formatting parameters=循环遍历多个命名范围和单元格值以控制各种 PowerPoint 格式参数=
【发布时间】：2015-05-02 09:50:03
【问题描述】：

我需要将多个（大约 70 个）命名范围从 Excel 粘贴到 PowerPoint 作为图片。每张图片可能有不同的高度、宽度、位置和目标幻灯片。我将在 Excel 表中包含所有参数。例如：

A 列：所有命名范围的列表 (NamedRange1)
B 列：命名范围的单元格引用 (Sheet1:$A$1:$B$4)
C 列：目标幻灯片编号
D-G 列：控制大小和位置参数的值

我花费了大量时间研究堆栈溢出和其他站点的解决方案，并拼凑了下面适用于单个命名范围的代码，但我想找到一个利用循环或数组的解决方案（或其他）以避免复制和粘贴代码 70 次并手动更新命名范围和单元格引用。

假设：用户将只打开 1 个 excel 工作簿和 1 个已包含适当数量幻灯片的 powerpoint 实例。

StackOverflow 的大佬们能帮忙吗？

Sub test()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.slide
Dim SlideNum As Integer
Set XLApp = GetObject(, "Excel.Application")


''define destination slide
SlideNum = Range("C2")
PPPres.Slides(SlideNum).Select
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

' Copy the range as a picture
XLApp.[namerange1].Copy
' Paste the range
PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select

' Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Height = Range("D2")
PPApp.ActiveWindow.Selection.ShapeRange.Width = Range("E2")

' Align the shape
PPApp.ActiveWindow.Selection.ShapeRange.Left = Range("G2")
PPApp.ActiveWindow.Selection.ShapeRange.Top = Range("F2")
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

End Sub

【问题讨论】：

标签： vba excel powerpoint excel-2013

【解决方案1】：

未经测试，但我建议您尝试以下代码。您可以使用ActiveWorkbook.Names 集合提取所有命名范围：

Dim nms as Range
Set nms = ActiveWorkbook.Names 

Dim r as Integer
For r = 1 To nms.Count 
    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.slide
    Dim SlideNum As Integer
    Set XLApp = GetObject(, "Excel.Application")


    ''define destination slide
    SlideNum = Range("C2")
    PPPres.Slides(SlideNum).Select
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    ' Copy the range as a picture
    XLApp.[nms(r)].Copy
    ' Paste the range
    PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select

    ' Align the pasted range
    PPApp.ActiveWindow.Selection.ShapeRange.Height = Range("D2")
    PPApp.ActiveWindow.Selection.ShapeRange.Width = Range("E2")

    ' Align the shape
    PPApp.ActiveWindow.Selection.ShapeRange.Left = Range("G2")
    PPApp.ActiveWindow.Selection.ShapeRange.Top = Range("F2")
    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
Next

您可能必须在循环内调整您的代码，因为我只编辑了对命名范围的引用。根据您想要的结果，硬编码的目的地范围可能必须更改为动态目的地。有关名称集合的更多信息：https://msdn.microsoft.com/en-us/library/office/ff841280.aspx。希望您觉得这个有帮助。干杯，

【讨论】：

【解决方案2】：

我有一个商业插件可以做这样的事情，除此之外；方法有点不同，但您可能会考虑在 PowerPoint 中添加矩形，只要您希望 Excel 内容出现。矩形的大小和位置可以决定粘贴的 Excel 内容的大小/位置。矩形中的文本可以指示要复制到 PPT 中以代替矩形的 Excel 范围的名称（之后您将删除该矩形）。

顺便说一句，如果你不需要的话，你永远都不想在 PPT 中选择任何东西。将一切都减慢一个数量级并使事情复杂化。而是使用如下结构：

Dim oSh as PowerPoint.Shape
Set oSh = PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)(1)
With oSh
   ' set the properties 
End With

【讨论】：