VBA BeforeSave事件致工作簿崩溃及重复录入问题求助

我正在创建一个多项目模板工作簿，每个项目有独立文件夹和工作簿，追踪困难。于是给工作簿加了BeforeSave事件，保存时打开Project Collector.xlsm，把当前工作簿路径存入其中。之前正常，现在出现两个问题：

• 单次保存会在Project Collector中重复添加2-5条路径
• 触发事件时两个工作簿会强制关闭，即使Project Collector能正常打开，也会在操作完成前崩溃

已尝试“打开并修复”、重建Project Collector，均无效；但在独立工作簿用命令按钮执行相同逻辑却正常。未用第三方插件，仅启用默认引用。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
        Cancel As Boolean)
    Application.EnableEvents = False
    Dim PrevFilePath As String
    Dim NewFilePath As String
    ' turn off screen write to eliminate screen flicker
    Application.ScreenUpdating = False
    
        If Sheets("Sheet5").Range("D70") <> Application.ActiveWorkbook.FullName And _
            Application.ActiveWorkbook.FullName <> "filepath\filename of template.xlsm" _
            Then 'if filepath or filename have changed since last opened, also does not trigger on the template file.
            PrevFilePath = Sheets("Sheet5").Range("D70") 'store the previous filepath
            NewFilePath = Application.ActiveWorkbook.FullName 'store the current filepath
            Sheets("Sheet5").Range("D70") = Application.ActiveWorkbook.FullName 'write the current filepath on this workbook
            GoTo UpdateProjectCollector
            Else
        End If
        DoEvents
    
    UpdateProjectCollector:
        'open Project Collector
        Workbooks.Open "\\filepath\Project Collector.xlsm" 'open Project Collector
        If Workbooks("Project Collector.xlsm").Sheets("Sheet1").Range("A:A").Find(PrevFilePath) Is Nothing Then
            Workbooks("Project Collector.xlsm").Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = NewFilePath
            
            Else: Workbooks("Project Collector.xlsm").Sheets("Sheet1").Range("A:A").Replace What:=PrevFilePath, Replacement:=NewFilePath 'replace the previous filepath w/ the new filepath
        End If
        DoEvents
        
        Workbooks("Project Collector").Close SaveChanges:=True 'save & close Project Collector
    ' turn screen write back on
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

1. GoTo逻辑漏洞：无论条件是否满足，都会执行UpdateProjectCollector代码块，即使不需要更新路径也会打开并修改Project Collector，触发额外保存操作导致事件重复触发。
2. 对象引用不严谨：直接用文件名引用工作簿，可能因大小写、扩展名显示设置等问题导致引用失败，引发崩溃。
3. 缺失错误处理：一旦操作出错，Application.EnableEvents和ScreenUpdating无法恢复，导致后续操作异常。
4. 事件重复触发：保存（尤其是SaveAs）内部可能多次触发BeforeSave事件，未正确控制流程导致重复执行更新逻辑。
5. Find参数不明确：默认参数可能导致匹配不准确，引发错误的添加/替换逻辑。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    ' 跳过SaveAs对话框触发的重复事件
    If SaveAsUI Then Exit Sub
    
    Dim wbCurrent As Workbook
    Dim wsTracker As Worksheet
    Dim wbCollector As Workbook
    Dim wsCollector As Worksheet
    Dim prevPath As String
    Dim newPath As String
    Dim foundCell As Range
    
    ' 初始化当前工作簿和追踪工作表
    Set wbCurrent = ThisWorkbook
    Set wsTracker = wbCurrent.Sheets("Sheet5")
    newPath = wbCurrent.FullName
    
    ' 跳过模板文件或路径未变更的情况
    If newPath = "filepath\filename of template.xlsm" Then Exit Sub
    If wsTracker.Range("D70").Value = newPath Then Exit Sub
    
    ' 关闭事件和屏幕刷新，避免循环触发和闪烁
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    On Error GoTo Cleanup ' 错误处理，确保恢复设置
    
    ' 更新当前工作簿的路径记录
    prevPath = wsTracker.Range("D70").Value
    wsTracker.Range("D70").Value = newPath
    
    ' 检查Project Collector是否已打开，避免重复打开
    On Error Resume Next
    Set wbCollector = Workbooks("Project Collector.xlsm")
    On Error GoTo Cleanup
    If wbCollector Is Nothing Then
        Set wbCollector = Workbooks.Open("\\filepath\Project Collector.xlsm")
    End If
    Set wsCollector = wbCollector.Sheets("Sheet1")
    
    ' 精确查找旧路径
    Set foundCell = wsCollector.Range("A:A").Find( _
        What:=prevPath, _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        MatchCase:=False)
    
    If foundCell Is Nothing Then
        ' 旧路径不存在，添加新路径到最后一行
        wsCollector.Cells(wsCollector.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = newPath
    Else
        ' 替换旧路径为新路径
        foundCell.Value = newPath
    End If
    
    ' 保存并关闭Collector（仅处理我们打开的文件）
    If Not wbCollector.ReadOnly Then
        wbCollector.Save
    End If
    If wbCollector.Path <> wbCurrent.Path Then
        wbCollector.Close SaveChanges:=False
    End If

Cleanup:
    ' 恢复Excel设置，无论是否出错都执行
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    ' 提示错误（如果有）
    If Err.Number <> 0 Then
        MsgBox "操作出错：" & Err.Description, vbCritical
        Err.Clear
    End If
End Sub

• 移除GoTo，改用结构化判断：仅在路径变更且不是模板文件时执行更新逻辑，避免不必要操作。
• 严谨对象引用：用变量存储工作簿/工作表对象，检查Collector是否已打开，避免引用错误。
• 错误处理机制：确保无论是否出错，都能恢复Excel的事件和屏幕刷新设置，防止异常状态。
• 避免重复触发：跳过SaveAsUI事件，路径未变更时直接退出，减少无效执行。
• 优化查找逻辑：指定精确匹配参数，用单元格替换代替整列替换，降低误操作风险。
• 安全关闭文件：先保存再关闭，避免数据丢失；仅关闭我们打开的Collector文件，防止误关用户正在使用的文件。

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