循环使用多个命名区域和单元格值来控制各种PowerPoint格式参数=

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

• 列A：所有命名范围的列表（NamedRange1）
• 列B：命名范围的单元格引用（Sheet1：$ A $ 1：$ B $ 4）
• 列C：目的地幻灯片号码
• DG列：控制大小和位置参数的值

我花了大量的时间研究堆栈溢出和其他网站的解决scheme，并将下面的代码拼凑在一个单一的命名范围，但我想find一个解决scheme，利用循环或数组（或任何否则）避免复制和粘贴代码70次，并手动更新命名的范围和单元格引用。

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

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 

Answer 1

未经testing，但我build议你尝试下面的代码。 您可以按照以下方式使用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 

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

Answer 2

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

顺便说一句，你永远不会想在PPT中select任何东西，如果你不需要。 将所有东西放慢一个数量级，使事情复杂化。 而是使用如下的构造：

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