Office更新杀死了我的VBA代码，将Excel表格粘贴到现有的PowerPoint文件和幻灯片中
在最近的Office 365更新之后，将表格从Excel复制到Power Point的代码停止工作。
前面的代码：
Sub GeneratePresentation() Dim pptApp As PowerPoint.Application Dim pptPrez As PowerPoint.Presentation Dim pSlide As PowerPoint.Slide Dim objPPT As Object Dim myRange As Excel.Range Set objPPT = CreateObject("PowerPoint.Application") objPPT.Visible = True MonthNo = Month(Worksheets("inputs").Range("B3")) MonthData = Worksheets("inputs").Cells(MonthNo + 10, 9) If MonthData = "" Then MsgBox "Please update losses" Else FilePath = "\\Model\" Filename = "Template Monthly reports.pptx" file = FilePath & Filename Set pptPrez = objPPT.Presentations.Open(file) Set pptApp = GetObject(Class:="PowerPoint.Application") Set pptPrez = pptApp.ActivePresentation 'Slide 1 title 1 Set pSlide = pptPrez.Slides(1) Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal""" Sheets("01").Range("D3").Copy Set osh = pSlide.Shapes.PasteSpecial(ppPasteDefault)(1) With osh .Top = 160 .Left = 135 .Height = 80 .Width = 550 End With 代码继续粘贴表格和图片。 然后
End if End sub
我得到以下错误：
VBA错误运行时'-2147188160（80048240）'：形状（未知成员）
我已经尝试了大多数的粘贴变体，但它只能让我粘贴图片或文字。 我注意到VBA参考库的修订似乎已经减less到Microsoft PowerPoint 14.0的对象库，当我相当确定它是build立15或16之前。 这是否是原因？
我想出了一个可以使用的解决scheme
'Slide 1 title 1 i = 1 Set pSlide = pptPrez.Slides(i) Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal""" Sheets("01").Range("D3").Copy pptPrez.Windows(1).Activate pptPrez.Windows(1).View.GotoSlide i pptPrez.Slides(i).Shapes("Title").Select pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting") With pptPrez.Slides(i) With .Shapes("Title") .LockAspectRatio = msoFalse .Top = 160 .Left = 135 .Height = 70 .Width = 550 '.TextFrame.TextRange.Font.Name = "Futura Bold" '.TextFrame.TextRange.Font.Size = 24 '.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft '.TextFrame.TextRange.ParagraphFormat.WordWrap = msoTrue End With End With
对于替代scheme，我必须手动创build所有的表格，然后命名它们，并在代码中select它们，但是它似乎不那么一致和可靠，要求活动的窗口更多出错。
任何想法如何让第一个代码再次工作？ 我仍然可以手动粘贴，但它似乎不使用pastespecial。 为什么更新会删除这个能力？ 我已经尝试过使用这个粘贴function从这个论坛validation的代码，但它不会工作，以前曾经，这绝对是更新，因为我们所有的计算机现在有同样的问题，我觉得很难相信。
我决定写一个答案，而不是一堆评论，因为我想发布我的代码。
那些Office 365更新已经引起我一三次了。 但是我不知道有什么问题。
代码在PasteSpecial上失败？ PasteSpecial是PowerPoint VBA的一个相对新手，但是我认为它是Office 14（2010）的一部分。 对PowerPoint库14.0版的引用很奇怪。 你可以去工具>参考和滚动到版本16.0？ 如果是这样，请检查一个。 您使用的是哪个版本的Office：转到文件选项卡>帐户，并find版本号和内部版本号。
为什么你有CreateObject和GetObject。 对于PowerPoint，您只需要使用CreateObject即可完成一次。 如果PowerPoint正在运行，则CreateObject将返回正在运行的实例; 如果不是，则返回一个新的实例。 可能不重要，但它增加了混乱。 将CreateObject移动到GetObject所在的位置，并将objPPT更改为pptApp（因为您不需要两者）。
另外，你已经使用了三个未声明的variables。 将MonthNo和MonthData声明为Variant，将osh声明为PowerPoint.Shape（实际上，在我的代码中，我将其重命名为pptShape，并将pSlide重命名为pptSlide以保持一致性）。
有了额外的修改，使用活动的演示文稿，而不是打开一个给定的path和文件名，你的代码对我来说工作得很好。 我正在运行版本1711，生成8711.2037，它的价值。
这里的代码对我来说运行良好。
Sub GeneratePresentation() Dim pptApp As PowerPoint.Application Dim pptPrez As PowerPoint.Presentation Dim pptSlide As PowerPoint.Slide Dim myRange As Excel.Range Dim pptShape As PowerPoint.Shape Dim MonthNo As Variant Dim MonthData As Variant MonthNo = Month(Worksheets("inputs").Range("B3")) MonthData = Worksheets("inputs").Cells(MonthNo + 10, 9) If MonthData = "" Then MsgBox "Please update losses" Else Set pptApp = GetObject(Class:="PowerPoint.Application") Set pptPrez = pptApp.ActivePresentation '' JP - use active presentation instead of opening one ''FilePath = "\\Model\" ''Filename = "Template Monthly reports.pptx" ''file = FilePath & Filename ''Set pptPrez = objPPT.Presentations.Open(file) Set pptPrez = pptApp.ActivePresentation 'Slide 1 title 1 Set pptSlide = pptPrez.Slides(1) Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" _ & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal""" Sheets("01").Range("D3").Copy Set pptShape = pptSlide.Shapes.PasteSpecial(ppPasteDefault)(1) With pptShape .Top = 160 .Left = 135 .Height = 80 .Width = 550 End With End If End Sub
我已经更新了替代解决scheme，可以帮助别人，因为它做了一些事情; 将表格复制到现有的演示文稿中，并将幻灯片更新为旧形状和新形状，然后使用popup框将图片复制到新的幻灯片，以便粘贴表格时进行select。
我做了一个function来做到这一点，以减less主要代码，并使其更容易pipe理，因为我有几十个副本和粘贴。 我没有粘贴任何东西，但显示了一些不同的方式来粘贴：
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) Private pptApp As PowerPoint.Application Private pptPres As PowerPoint.Presentation Private pSlide As PowerPoint.Slide Private TTop, TLeft As Variant Private TableCount, SlideNo As Integer Private MyRange As Excel.Range Private ShapeName As String Private Function CreateTable() Dim l As Long Set pSlide = pptPres.Slides(SlideNo) MyRange.Copy pptPres.Windows(1).Activate pptPres.Windows(1).View.GotoSlide SlideNo With pptPres.Slides(SlideNo) If ShapeName = isblank Then Else pptPres.Slides(SlideNo).Shapes(ShapeName).Select End If For l = 1 To 100 DoEvents Next l pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting") For l = 1 To 500 DoEvents Next l pptApp.CommandBars.ReleaseFocus NoShapes = pSlide.Shapes.Count If ShapeName = isblank Then pptPres.Slides(SlideNo).Shapes(NoShapes).Name = "Table" & TableCount pptPres.Slides(SlideNo).Shapes(ShapeName).Select With .Shapes("Table" & TableCount) .LockAspectRatio = msoFalse If TTop = isblank Then Else .Top = TTop End If If TLeft = isblank Then Else .Left = TLeft End If End With TableCount = TableCount + 1 Else End If End With ShapeName = "" TLeft = "" TTop = "" Application.CutCopyMode = False End Function Sub GeneratePresentation() Dim FilePath, Filename, file As String Dim MonthNo, MonthData As Variant Dim x, y As Variant Dim UpdateRecords As Integer Dim WB As Excel.Workbook FilePath = "\\\Model\" Filename = "Template Weekly Report.pptx" file = FilePath & Filename Set pptApp = New PowerPoint.Application Set pptPres = pptApp.Presentations.Open(file) ' using a specific presentation or template Set pptPres = pptApp.ActivePresentation TableCount = 1 'Slide 1 title 1 SlideNo = 1 Sheets("01").Range("D3") = "= ""Weekly Report """ Sheets("01").Range("D4") = "= ""For Week No. ""&TEXT(WEEKNUM(NOW(),16),""#"")& "" - internal""" Set MyRange = Sheets("0" & SlideNo).Range("D3:D4") TTop = 160 TLeft = 135 Call CreateTable 'Slide 1 title 2 Sheets("01").Range("D7").Formula = "=DAY(Entry!B4)&LOOKUP(DAY(Entry!B4),{1,2,3,4,21,22,23,24,31;""st"",""nd"",""rd"",""th"",""st"",""nd"",""rd"",""th"",""st""})&TEXT(Entry!B4,"" mmmm yyy"")" Set MyRange = Sheets("0" & SlideNo).Range("D7") TTop = 280 TLeft = 135 Call CreateTable 'slide 2 table 1 SlideNo = 2 Set MyRange = Sheets("0" & SlideNo).Range("B33:T40") TTop = 380 Call CreateTable 'Slide 2 chart 1 ActiveWorkbook.Sheets("0" & SlideNo).ChartObjects("Chart 1").Copy Set osh = pSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)(1) With osh .Top = 98 .Left = 35 .Width = 430 End With 'Slide 3 table 1 SlideNo = 3 Set pSlide = pptPres.Slides(SlideNo) UpdateRecords = MsgBox("Update Records", vbYesNo, "Update Records?") If UpdateRecord = yes Then Set MyRange = Sheets("0" & SlideNo).Range("E17:I20") TTop = 330 Call CreateTable Else End If pptPres.Windows(1).Activate pptPres.Windows(1).View.GotoSlide 1 End Sub
我希望这是有帮助的。
如果您有任何build议，请告诉我。
乔恩