MS Project VBA添加新日历例外前删除现有例外的问题求助

问题背景 #

需要实现从Excel表格导入假期到MS Project日历前，先删除目标日历的所有现有例外，但原有的删除代码执行失败，无法完成清空操作。

问题原因 #

原代码使用For Each遍历Exceptions集合并删除元素，这种方式会因集合结构动态变化导致遍历异常（跳过元素或触发错误）。此外，原删除子过程仅针对当前项目日历，未适配Excel中指定的目标日历。

修正后的完整代码 #

日历例外删除子过程 #

Sub deleteCalendarExceptions(calName As String)
    Dim i As Integer
    Dim exceptionsCount As Integer
    
    ' 获取目标日历的例外总数
    exceptionsCount = ActiveProject.BaseCalendars(calName).Exceptions.Count
    
    ' 从最后一个例外开始逆向删除，避免集合索引变化引发的问题
    For i = exceptionsCount To 1 Step -1
        ActiveProject.BaseCalendars(calName).Exceptions(i).Delete
    Next i
End Sub

主导入过程（含前置清空逻辑） #

Sub LoadHolidaysFromExcel()
    Dim objXL As Object
    Dim objWB As Object
    Dim objWS As Object
    Dim MyFile As String
    Dim LR As Integer
    Dim x As Integer
    Dim MyName As String
    Dim MyStart As Date
    Dim MyFinish As Date
    Dim MyCalendar As String
    Dim uniqueCalendars As Collection
    Dim cal As Variant
    
    Set objXL = CreateObject("Excel.Application")
    MyFile = objXL.GetOpenFilename
    
    ' 用户取消选择文件时直接退出
    If MyFile = "False" Then
        objXL.Quit
        Set objXL = Nothing
        Exit Sub
    End If
    
    Set objWB = objXL.Workbooks.Open(MyFile)
    Set objWS = objWB.Worksheets(1)
    Set uniqueCalendars = New Collection
    
    ' 收集所有需要处理的唯一日历名称，避免重复删除
    LR = objWS.Range("A1").CurrentRegion.Rows.Count
    On Error Resume Next
    For x = 2 To LR
        MyCalendar = objWS.Cells(x, 4).Value
        If MyCalendar <> "" Then
            uniqueCalendars.Add MyCalendar, Key:=UCase(MyCalendar)
        End If
    Next x
    On Error GoTo 0
    
    ' 清空每个目标日历的所有现有例外
    For Each cal In uniqueCalendars
        deleteCalendarExceptions cal
    Next cal
    
    ' 从Excel导入新的假期例外
    For x = 2 To LR
        MyName = objWS.Cells(x, 1).Value
        MyStart = objWS.Cells(x, 2).Value
        MyFinish = objWS.Cells(x, 3).Value
        MyCalendar = objWS.Cells(x, 4).Value
        
        ' 基础校验：确保日历名称有效、日期格式正确
        If MyCalendar <> "" And IsDate(MyStart) And IsDate(MyFinish) Then
            ActiveProject.BaseCalendars(MyCalendar).Exceptions.Add _
                Type:=1, Start:=MyStart, Finish:=MyFinish, Name:=MyName
        End If
    Next x
    
    ' 清理资源，避免Excel后台进程残留
    objXL.Workbooks.Close SaveChanges:=False
    objXL.Quit
    Set objWS = Nothing
    Set objWB = Nothing
    Set objXL = Nothing
    
    MsgBox "假期导入完成！"
End Sub

关键改进点 #

1. 逆向遍历删除：通过从最后一个元素到第一个元素的索引遍历，彻底避免集合动态变化导致的遍历异常。
2. 唯一日历收集：先提取Excel中所有需要处理的日历名称并去重，避免同一日历被多次执行删除操作，提升效率。
3. 数据校验：增加日历名称非空、日期有效性检查，防止导入无效数据。
4. 资源清理：完善Excel对象的释放逻辑，避免后台残留Excel进程。

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