XLS VBA：Outlook日历时间对比存在细微错误

我编写了Excel VBA的PullAllMeetings函数，功能为从指定同事的Outlook日历提取会议，生成起始日期至结束日期内的所有30分钟时段列表，若任一人员在该时段存在会议冲突则移除对应时段；同时包含处理每周、双周、月度重复会议的辅助函数。但该函数存在问题：有时会错误移除或遗漏会议前后的30分钟时段，推测是VBA日期时间对比时因浮点精度问题产生±0.001的误差导致，尝试过调整但未找到可行方案，恳请提供解决思路。

Sub PullAllMeetings()

    Application.ScreenUpdating = False
    
    Dim startDate As Date
    Dim endDate As Date
    Dim slotSize As Double
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.Namespace
    Dim objCalendar As Outlook.MAPIFolder
    Dim objAppointment As Outlook.AppointmentItem
    Dim objRecurrence As Outlook.RecurrencePattern
    Dim objOccurrence As Outlook.AppointmentItem
    Dim objAppointments As Outlook.Items  ' added to pull recurring appointments
    Dim row As Long
    
    Range("F4:G10000").Clear
    Range("F4:F10000").HorizontalAlignment = xlCenter
    Range("G4:G10000").HorizontalAlignment = xlLeft
    
    ' get date from cells
    startDate = Range("D4").Value
    endDate = Range("D5").Value
    emailRange = Range("C12:C26").Value
    
    slotSize = Range("D6").Value
    RecSwitch = Range("D7").Value
    
    ' set start and end times for  search
    startDate = DateSerial(Year(startDate), Month(startDate), Day(startDate))
    endDate = DateAdd("d", 1, DateSerial(Year(endDate), Month(endDate), Day(endDate)))
    freeTimes = createDateArray(startDate, endDate)

    For Each emailAddress In emailRange
        If Not IsEmpty(emailAddress) Then
            
            Set objOutlook = New Outlook.Application
            Set objNamespace = objOutlook.GetNamespace("MAPI")
            
            ' added to pull recurring appointments
            Set recipient = objNamespace.CreateRecipient(emailAddress)
            Set objAppointments = objNamespace.GetSharedDefaultFolder(recipient, 9).Items.Restrict("[Start] >= """ & startDate & """ and [Start] <= """ & endDate & """")
            objAppointments.Sort "[Start]"
            
            objAppointments.IncludeRecurrences = True
            Set objAppointment = objAppointments.Find("[Start] >= """ & startDate & """ and [Start] <= """ & endDate & """ and [Duration] > 0")
            
            row = 1
            Do While TypeName(objAppointment) <> "Nothing"
        
                    If objAppointment.Duration <> 0 Then
                        
                        startTime = objAppointment.Start
                        endTime = DateAdd("n", objAppointment.Duration, objAppointment.Start)
                        
                        low = LBound(freeTimes)
                        high = UBound(freeTimes)
                        
                        i = low
                        
                        While i <= high
                            
                            'Start time of appointment is less than start time of slot. End time of appointment is greater than end time of slot
                            'Debug.Print startTime, endTime, freeTimes(i), DateAdd("n", slotSize, freeTimes(i)), startTime <= freeTimes(i), endTime > freeTimes(i)
                            If startTime <= freeTimes(i) And endTime - 0.001 > freeTimes(i) Then
                                DeleteFromArrayAtIndex freeTimes, i
                                i = 0
                                high = high - 1
                            'Start time of appointment is less than end time of slot. End time of appointment is greater than end time of slot
                            ElseIf startTime + 0.001 < DateAdd("n", slotSize, freeTimes(i)) And endTime >= DateAdd("n", slotSize, freeTimes(i)) Then
                                DeleteFromArrayAtIndex freeTimes, i
                                i = 0
                                high = high - 1
                            End If
                            
                            i = i + 1
                        Wend
                        
                        row = row + 1
                        Set objAppointment = objAppointments.FindNext
                        
                    End If
            Loop
            
            Set objOutlook = Nothing
            Set objNamespace = Nothing
            Set objCalendar = Nothing
            Set objAppointment = Nothing
            Set objRecurrence = Nothing
            Set objOccurrence = Nothing
            Set objAppointments = Nothing
            
        End If
    Next
    
    LastDate = DateAdd("d", -1, freeTimes(0))
    Max = UBound(freeTimes)
    offsetCount = 0
    For slotCount = 0 To Max
        
        If slotSize > 30 Then
            For x = 0 To (slotSize / 30) - 1
                If slotCount + x < Max Then
                    If freeTimes(slotCount) - freeTimes(slotCount + x) = 30 Then
                        slotCount = slotCount + 1
                        Exit For
                    End If
                End If
            Next x
        End If
        
        Range("G4").Offset(offsetCount, 0).Font.Bold = False
        If DateSerial(Year(LastDate), Month(LastDate), Day(LastDate)) <> DateSerial(Year(freeTimes(slotCount)), Month(freeTimes(slotCount)), Day(freeTimes(slotCount))) Then
            offsetCount = offsetCount + 1
            Range("G4").Offset(offsetCount, 0).Value = DateSerial(Year(freeTimes(slotCount)), Month(freeTimes(slotCount)), Day(freeTimes(slotCount)))
            Range("G4").Offset(offsetCount, 0).NumberFormat = "dddd, mmm-d, yyyy"
            Range("G4").Offset(offsetCount, 0).Font.Bold = True
            offsetCount = offsetCount + 1
            LastDate = DateSerial(Year(freeTimes(slotCount)), Month(freeTimes(slotCount)), Day(freeTimes(slotCount)))
        End If
        
        If RecSwitch Then
            W = IsTimeAvailable(freeTimes(slotCount), freeTimes, startDate, endDate)
            If W Then Range("F4").Offset(offsetCount, 0).Value = "W"
            f = IsTimeAvailableFortnightly(freeTimes(slotCount), freeTimes, startDate, endDate)
            If W Then abc = ", F" Else abc = "F"
            If f Then Range("F4").Offset(offsetCount, 0).Value = Range("F4").Offset(offsetCount, 0).Value & abc
            M = NextSameWeekdayAndWeek(freeTimes(slotCount), freeTimes)
            If W Or f Then abc = ", M" Else abc = "M"
            If M Then Range("F4").Offset(offsetCount, 0).Value = Range("F4").Offset(offsetCount, 0).Value & abc
        End If
        
        Range("G4").Offset(offsetCount, 0).Value = Format(freeTimes(slotCount), "h:mm AM/PM") & " – " & Format(DateAdd("n", slotSize, freeTimes(slotCount)), "h:mm AM/PM")
        'Range("D1").Offset(offsetCount, 0).NumberFormat = "h:mm am/pm"
        offsetCount = offsetCount + 1
        
    Next slotCount
    
    Application.ScreenUpdating = True
    
End Sub

Function createDateArray(startDate As Date, endDate As Date) As Variant
    
    Dim dateArray() As Date
    Dim i As Long
    Dim currentDate As Date
    sTime = Range("D8").Value & ":00:00"
    eTime = Range("D9").Value & ":00:00"
    
    mEndDate = DateAdd("d", -1, DateSerial(Year(endDate), Month(endDate), Day(endDate)))
    
    currentDate = startDate
    i = 0
    
    Do Until currentDate > mEndDate
        
        If Weekday(currentDate, vbMonday) > 5 Then GoTo ContinueDo
        
        
        For currentTime = TimeValue(sTime) To TimeValue(eTime) Step 30 / (24 * 60)
            ReDim Preserve dateArray(i)
            dateArray(i) = currentDate + currentTime
            i = i + 1
        Next currentTime
        
ContinueDo:
        currentDate = currentDate + 1
    Loop
    
    createDateArray = dateArray
    
End Function

Sub DeleteFromArrayAtIndex(arr As Variant, index)
    Dim myInt As Long
    If mIndex >= LBound(arr) And index <= UBound(arr) Then
        ' Shift elements to the left
        For myInt = index To UBound(arr) - 1
            arr(myInt) = arr(myInt + 1)
        Next myInt
        ' Resize the array
        ReDim Preserve arr(LBound(arr) To UBound(arr) - 1)
    End If
End Sub


'Recurring check

Function NextSameWeekdayAndWeek(inputDate, datesArray As Variant)
    Dim inputWeekNum As Integer
    Dim inputWeekday As Integer
    
    inputWeekday = Weekday(inputDate)
    x = GetCalendarTypeMonthWeek(inputDate)
    inputWeekNum = x

    For i = 0 To UBound(datesArray)
        If GetCalendarTypeMonthWeek(datesArray(i)) = inputWeekNum And Weekday(datesArray(i)) = inputWeekday And Format(datesArray(i), "hh:mm") = Format(inputDate, "hh:mm") And datesArray(i) > inputDate Then
            'Debug.Print datesArray(i)
            NextSameWeekdayAndWeek = True
            Exit Function
        End If
    Next i
    
    NextSameWeekdayAndWeek = False
    
End Function

Function GetCalendarTypeMonthWeek(dt) As Integer

    Dim lngDayOfMonth As Long
    Dim lngWeekDay As Long
    Dim dtFirstDayOfMonth As Date
    Dim lngFactor As Long

    lngDayOfMonth = Day(dt)
    lngWeekDay = Weekday(dt, vbSunday) '<~~ Sunday=1, Monday=2, etc
    
    'does month start on Sunday?
    dtFirstDayOfMonth = DateValue("01-" & Month(dt) & "-" & Year(dt))
    If Weekday(dtFirstDayOfMonth, vbSunday) = 1 Then
        lngFactor = 1
    Else
        lngFactor = 2
    End If
    
    'get calendar week number for date
    GetCalendarTypeMonthWeek = Int((lngDayOfMonth - lngWeekDay) / 7) + lngFactor

End Function

Function IsTimeAvailable(inputDate, dateArray As Variant, sDate, eDate) As Boolean
    Dim i As Integer
    Dim inputDay As Integer
    Dim inputTime As Double
    
    IsTimeAvailable = False
    inputDay = Weekday(inputDate) 'determine the day of the week of the input date
    inputTime = TimeValue(inputDate) 'determine the time of the input date
    
    DCount = -1
    tCount = -1
    
    LastDate = Format(DateAdd("d", 0, sDate), "mm/dd/yyyy")
    ldate = Format(DateAdd("d", 0, sDate), "mm/dd/yyyy")
    
    dayDiff3 = Abs(DateDiff("d", eDate, dateArray(UBound(dateArray))))
    If dayDiff3 > 7 Then
        IsTimeAvailable = False
        Exit Function
    End If
    
    For i = LBound(dateArray) To UBound(dateArray)
        
        dayDiff2 = Abs(DateDiff("d", dateArray(i), LastDate))
        If dayDiff2 > 7 Then
            IsTimeAvailable = False
            Exit Function
        End If
        
        If Weekday(dateArray(i)) = inputDay Then
            If LastDate <> Format(dateArray(i), "mm/dd/yyyy") Then
                DCount = DCount + 1
            End If
            If TimeValue(dateArray(i)) = inputTime Then
                tCount = tCount + 1
            End If
            LastDate = Format(dateArray(i), "mm/dd/yyyy")
        End If
        
        ldate = Format(dateArray(i), "mm/dd/yyyy")
        
    Next i
    
    If DCount = tCount And DCount > 0 Then IsTimeAvailable = True
    
End Function

Function IsTimeAvailableFortnightly(inputDate, dateArray As Variant, sDate, eDate) As Boolean

    Dim i As Integer
    Dim inputDay As Integer
    Dim inputTime As Double
    Dim dayDiff As Integer
    
    IsTimeAvailableFortnightly = False
    inputDay = Weekday(inputDate) 'determine the day of the week of the input date
    inputTime = TimeValue(inputDate) 'determine the time of the input date
    
    DCount = -1
    tCount = -1
    LastDate = Format(DateAdd("d", 0, dateArray(0)), "mm/dd/yyyy")
    ldate = Format(DateAdd("d", 0, dateArray(0)), "mm/dd/yyyy")
    
    dayDiff3 = Abs(DateDiff("d", eDate, dateArray(UBound(dateArray))))
    If dayDiff3 > 14 Then
        IsTimeAvailableFortnightly = False
        Exit Function
    End If
    
    For i = LBound(dateArray) To UBound(dateArray)
    
        dayDiff = Abs(DateDiff("d", inputDate, dateArray(i)))
        dayDiff2 = Abs(DateDiff("d", dateArray(i), LastDate))
        
        If dayDiff2 > 14 Then
            IsTimeAvailableFortnightly = False
            Exit Function
        End If
        
        If Weekday(dateArray(i)) = inputDay And dayDiff Mod 14 = 0 Then
            If LastDate <> Format(dateArray(i), "mm/dd/yyyy") Then
                DCount = DCount + 1
            End If
            If TimeValue(dateArray(i)) = inputTime Then
                tCount = tCount + 1
            End If
            LastDate = Format(dateArray(i), "mm/dd/yyyy")
        End If
        ldate = Format(dateArray(i), "mm/dd/yyyy")
    
    Next i
    
    If DCount = tCount And DCount > 0 Then IsTimeAvailableFortnightly = True
    
End Function

解决思路 #

• 统一日期时间为整数精度对比
  VBA的Date类型本质是Double，小数部分代表时间，直接对比易产生浮点误差。可以把所有日期时间转换为从基准日开始的总分钟数整数，彻底规避精度问题：

  Function DateToTotalMinutes(dt As Date) As Long
      DateToTotalMinutes = CLng((dt - #1/1/1900#) * 24 * 60)
  End Function
  

  后续所有时段、会议的起止时间都用该函数转换后再判断冲突。

• 重构冲突判断逻辑
  原代码的分情况判断逻辑有漏洞，应直接判断时段与会议是否存在重叠：只要会议结束时间晚于时段开始时间，且会议开始时间早于时段结束时间，就判定为冲突。用整数分钟数对比后逻辑更清晰：

  Dim slotStartMin As Long, slotEndMin As Long
  Dim meetingStartMin As Long, meetingEndMin As Long
  
  slotStartMin = DateToTotalMinutes(freeTimes(i))
  slotEndMin = DateToTotalMinutes(DateAdd("n", slotSize, freeTimes(i)))
  meetingStartMin = DateToTotalMinutes(startTime)
  meetingEndMin = DateToTotalMinutes(endTime)
  
  ' 重叠判断逻辑
  If meetingEndMin > slotStartMin And meetingStartMin < slotEndMin Then
      DeleteFromArrayAtIndex freeTimes, i
      high = high - 1
  End If
  

• 修复数组删除的参数错误
  原DeleteFromArrayAtIndex子程序中误用了未定义的mIndex参数，导致索引判断失效，修正后应使用传入的index：

  Sub DeleteFromArrayAtIndex(arr As Variant, index As Long)
      Dim myInt As Long
      If index >= LBound(arr) And index <= UBound(arr) Then
          For myInt = index To UBound(arr) - 1
              arr(myInt) = arr(myInt + 1)
          Next myInt
          ReDim Preserve arr(LBound(arr) To UBound(arr) - 1)
      End If
  End Sub
  

• 优化数组遍历方式
  原代码删除元素后重置i=0会导致重复遍历，效率低且易出错。改为从后往前遍历，删除元素时无需重置索引：

  i = high
  While i >= low
      ' 冲突判断逻辑
      If 冲突条件 Then
          DeleteFromArrayAtIndex freeTimes, i
          high = high - 1
      End If
      i = i - 1
  Wend
  

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