PowerPoint VBA批量生成PPT触发不稳定错误求助

我是VBA新手，开发了如下宏功能：遍历源文件夹内的PPT文件，提取指定文本框中的字符串及对应幻灯片索引存入工作表；提取唯一字符串后，基于PPT模板生成以该字符串命名的新PPT，并复制对应源幻灯片到新PPT（若文件已存在则打开并追加幻灯片）。

当生成的目标PPT数量超过10个左右时，PowerPoint会弹出错误提示："We're sorry something went wrong that might make PowerPoint Unstable. Please save your presentations and restart PowerPoint."，点击确定后宏可继续运行，但每生成5-6个PPT就会重复触发该错误，且无法定位到Excel代码中触发错误的具体行。

我已尝试清理注册表、关闭杀毒软件、添加Application.Wait延迟、每次生成目标PPT前重启PowerPoint实例、使用双PowerPoint实例分别处理源文件与目标文件等方法，均未解决问题，恳请提供解决方案或规避方法。

Sub CreateNewPPTForeachPN(lPNinitialLastRow As Long, iOutputRowCounter As Long, ppApp As PowerPoint.Application, oFSO As Object)

Dim ii As Long
Dim jj As Long
Dim ppTarget As PowerPoint.Presentation
Dim ppSource As PowerPoint.Presentation
Dim ppTemp As PowerPoint.Presentation
Dim ppConsol As PowerPoint.Presentation
Dim sAllPNs() As Variant
Dim sProcess As String
Dim sUniquePN() As String
Dim sUniqueFileNames() As String
Dim sFileNameSummary As String
Dim iFileNameCounter As Long
Dim iArrayCounter As Long
Dim sNewPPTName As String
Dim icounter As Long
Dim IrowCount As Long
Dim lNewLastRow As Long

IrowCount = wsPartNumberLog.Cells(1, 3).End(xlDown).Row
lNewLastRow = lPNinitialLastRow + 1


sAllPNs() = wsPartNumberLog.Range("C" & lNewLastRow, "C" & IrowCount).Value
'sAllPNs() = wsPartNumberLog.Cells(lNewLastRow, 3).Resize(IrowCount - lNewLastRow + 1, 1).Value
'sAllPNs() = wsPartNumberLog.Range(wsPartNumberLog.Cells(3, lNewLastRow), wsPartNumberLog.Cells(3, IrowCount)).Value


sUniquePN = ExtractUniqueValues(sAllPNs(), lNewLastRow)


For iArrayCounter = LBound(sUniquePN) To UBound(sUniquePN)
    
    sNewPPTName = sUniquePN(iArrayCounter)
    
    'Find unique SfileName associated with unique PN
    sUniqueFileNames = FindUniqueFileNamesSourceForPN(IrowCount, sNewPPTName)
    sFileNameSummary = ""
    
    'Populate summary with every unique File with unique PN
    For iFileNameCounter = LBound(sUniqueFileNames) To UBound(sUniqueFileNames)
        sFileNameSummary = sFileNameSummary & sUniqueFileNames(iFileNameCounter) & vbNewLine
    Next iFileNameCounter
    
    
    Call OpenPPTifNotOpened(ppApp)
    
    
    'Check for file existence
    If oFSO.fileexists(wsOptions.Range("Opt_sTarget").Value & "\" & sNewPPTName & ".pptx") Then
        
    
        'Get existing file
        Set ppConsol = Getppt(wsOptions.Range("Opt_sTarget").Value & "\" & sNewPPTName & ".pptx", ppApp)
        
        With ppConsol
            .Slides(1).Shapes("Date Placeholder 7").TextFrame.TextRange.Text = Date
            .Slides(2).Shapes("Content Placeholder 9").TextFrame.TextRange.Text = sFileNameSummary
            
            For icounter = lNewLastRow To IrowCount
                If wsPartNumberLog.Cells(icounter, 3) = sNewPPTName Then
                    
                    Set ppSource = ppApp.Presentations.Open(wsOptions.Range("Opt_Spath").Value & "\" & wsPartNumberLog.Cells(icounter, 2).Value, ReadOnly:=msoTrue) 'Add read only option to GetFilesFromSource
                    Call InsertSlide_Source(ppConsol, ppSource.Slides(wsPartNumberLog.Cells(icounter, 4).Value))
                    ppSource.Close
                    Set ppSource = Nothing

                End If
            
            Next icounter
            
            'OutputFiles Log
            
            wsOutputLog.Cells(iOutputRowCounter + 1, 1).Value = iOutputRowCounter
            wsOutputLog.Cells(iOutputRowCounter + 1, 2).Value = ppConsol.Name
            wsOutputLog.Cells(iOutputRowCounter + 1, 3).Value = ppConsol.Slides.Count
            wsOutputLog.Cells(iOutputRowCounter + 1, 4).Value = Now()
            iOutputRowCounter = iOutputRowCounter + 1
            
            'Save new powerpoint
            ppConsol.Save
            ppConsol.Close
            
            'ppApp.Quit
            Set ppApp = Nothing
            
        End With
    
    Else
            
        'get the template
        Set ppTemp = Getppt(wsOptions.Range("Opt_Temp").Value, ppApp)
        
        'Populate the template with the relevant information related to the unique PN
        With ppTemp
            .SaveAs wsOptions.Range("Opt_sTarget").Value & "\" & sNewPPTName, ppSaveAsDefault
            .Slides(1).Shapes("Title 1").TextFrame.TextRange.Text = sNewPPTName & "_Consolidated Slides"
            .Slides(1).Shapes("Date Placeholder 7").TextFrame.TextRange.Text = Date
            .Slides(2).Shapes("Content Placeholder 9").TextFrame.TextRange.Text = sFileNameSummary
            
            'For every new occurence of the PN in the workbook, open the source ppt and copy to the new ppt
            For icounter = 2 To IrowCount
                
                If wsPartNumberLog.Cells(icounter, 3) = sNewPPTName Then
                    
                    Set ppSource = ppApp.Presentations.Open(wsOptions.Range("Opt_Spath").Value & "\" & wsPartNumberLog.Cells(icounter, 2).Value, ReadOnly:=msoTrue)
                    Call InsertSlide_Source(ppTemp, ppSource.Slides(wsPartNumberLog.Cells(icounter, 4).Value))
                    ppSource.Close
                    Set ppSource = Nothing
                    
                End If
            
            Next icounter
                        
            'OutputFiles Log
            
            wsOutputLog.Cells(iOutputRowCounter + 1, 1).Value = iOutputRowCounter
            wsOutputLog.Cells(iOutputRowCounter + 1, 2).Value = ppTemp.Name
            wsOutputLog.Cells(iOutputRowCounter + 1, 3).Value = ppTemp.Slides.Count
            wsOutputLog.Cells(iOutputRowCounter + 1, 4).Value = Now()
            iOutputRowCounter = iOutputRowCounter + 1
            
            'Save new powerpoint
            ppTemp.Save
            ppTemp.Close
            
            'ppApp.Quit
            Set ppApp = Nothing


            
        End With
        
    End If
        

Next iArrayCounter



End Sub

1. 修复对象释放逻辑错误 #

代码中在处理单个PPT后执行Set ppApp = Nothing，但后续循环仍需要使用该实例，会导致引用失效引发不稳定。必须移除循环内部的Set ppApp = Nothing及注释的ppApp.Quit，改为在整个宏执行完毕后统一清理：

' 在Next iArrayCounter循环结束后添加：
ppApp.Quit
Set ppApp = Nothing

2. 优化资源释放流程 #

每次处理完目标PPT后，强制释放相关对象并触发系统资源回收：

' 在ppConsol.Close或ppTemp.Close后添加：
Set ppConsol = Nothing ' 对应处理已存在PPT的分支
' 或Set ppTemp = Nothing ' 对应新建PPT的分支
DoEvents ' 让系统处理未完成的后台操作
Application.CutCopyMode = False ' 清除剪贴板残留内容

3. 定期重启PPT实例 #

每处理5-6个PPT后主动重启PPT实例，避免长期运行导致的资源泄漏：

' 在For iArrayCounter循环内添加计数判断：
Static processCount As Integer
processCount = processCount + 1
If processCount Mod 5 = 0 Then
    ' 关闭当前实例
    ppApp.Quit
    Set ppApp = Nothing
    ' 重新创建实例
    Set ppApp = New PowerPoint.Application
    ppApp.Visible = False ' 后台运行减少资源占用
    ppApp.DisplayAlerts = ppAlertsNone ' 禁用弹窗提示
    processCount = 0
End If

4. 优化幻灯片复制逻辑 #

避免频繁打开/关闭源PPT，或替换自定义InsertSlide_Source函数为原生复制粘贴方法，减少资源消耗：

' 替换原InsertSlide_Source调用代码：
ppSource.Slides(wsPartNumberLog.Cells(icounter, 4).Value).Copy
ppConsol.Slides.Paste
Application.CutCopyMode = False

5. 禁用PPT后台冗余功能 #

初始化PPT实例时关闭自动恢复、实时预览等功能，降低资源占用：

' 在创建PPT实例时添加：
Set ppApp = New PowerPoint.Application
With ppApp
    .AutoRecover.Enabled = False
    .DisplayAlerts = ppAlertsNone
    .Visible = False
End With

6. 检查自定义函数 #

排查Getppt和OpenPPTifNotOpened函数，确保它们不会创建重复的PPT实例，且正确返回Presentation对象引用，避免实例冲突。

内容的提问来源于stack exchange，提问作者GDHumanBeing