VBA日期差计算修正：跨月精度问题及与Wolfram Alpha对齐需求

问题背景 #

需要编写VBA代码准确计算两个日期的年、月、日差值，要求结果与Wolfram Alpha完全一致，但现有代码在处理以下案例时出错：

• 输入日期30/03/1955与26/05/2024，正确结果应为69年、1个月、27天（总天数25,260），但现有代码日数错误显示为26天。

问题原因 #

原代码使用DateAdd函数计算月份偏移时，会自动将非法日期（如31/04）调整为合法日期（01/05），导致后续计算日数时出现偏差。同时，月份差的判断逻辑未充分考虑日期的合法性，无法匹配Wolfram Alpha的计算规则。

修正方案 #

1. 添加月份天数辅助函数 #

首先添加一个私有函数，用于计算指定年月的天数：

Private Function DaysInMonth(ByVal yearNum As Integer, ByVal monthNum As Integer) As Integer
    ' 返回指定年月的天数，利用DateSerial生成下月第一天的前一天
    DaysInMonth = Day(DateSerial(yearNum, monthNum + 1, 0))
End Function

2. 修改年、月、日计算逻辑 #

替换原代码中年份之后的月份和天数计算部分，改为以下逻辑：

' Calculate date after adding full years
tempDate = DateSerial(Year(data1) + anni, Month(data1), Day(data1))

' Calculate months difference
mesi = Month(data2) - Month(tempDate)
' Adjust if day of data2 is earlier than day of tempDate
If Day(data2) < Day(tempDate) Then
    mesi = mesi - 1
End If

' Handle negative months (edge case protection)
If mesi < 0 Then
    mesi = mesi + 12
    anni = anni - 1
    tempDate = DateSerial(Year(tempDate) - 1, Month(tempDate), Day(tempDate))
End If

' Calculate target year and month after adding full months
Dim targetYear As Integer, targetMonth As Integer
targetYear = Year(tempDate)
targetMonth = Month(tempDate) + mesi
If targetMonth > 12 Then
    targetYear = targetYear + 1
    targetMonth = targetMonth - 12
End If

' Adjust tempDate to valid date in target month
If Day(tempDate) > DaysInMonth(targetYear, targetMonth) Then
    ' Use last day of target month if original day is invalid
    tempDate = DateSerial(targetYear, targetMonth + 1, 0)
Else
    tempDate = DateSerial(targetYear, targetMonth, Day(tempDate))
End If

' Calculate remaining days directly (VBA date subtraction gives day count)
giorni = data2 - tempDate

完整修正后代码 #

Option Explicit

Private Function DaysInMonth(ByVal yearNum As Integer, ByVal monthNum As Integer) As Integer
    DaysInMonth = Day(DateSerial(yearNum, monthNum + 1, 0))
End Function

Public Function DiffDate44(ByVal data1 As Variant, ByVal data2 As Variant, dato_richiesto As String, valori_assoluti As Boolean) As Variant
    Dim anni As Integer, mesi As Integer, giorni As Integer
    Dim giorni_totali As Long
    Dim dummy As Date, tempDate As Date
    Dim anniStr As String, mesiStr As String, giorniStr As String, giorni_totaliStr As String, spaziatura As String

    On Error GoTo ErrorHandler
    
    ' Convert inputs to Date type
    data1 = CDate(data1)
    data2 = CDate(data2)
    
    ' Handle absolute values if required
    If valori_assoluti = True Then
        If data1 > data2 Then
            dummy = data1
            data1 = data2
            data2 = dummy
        End If
    Else
        If data1 > data2 Then
            MsgBox "ERRORE: Data1 > Data2!"
            DiffDate44 = "ERRORE DiffDate"
            Exit Function
        End If
    End If

    ' Calculate total days difference (direct subtraction is reliable)
    giorni_totali = Abs(data2 - data1)

    ' Calculate years
    anni = Year(data2) - Year(data1)
    If DateSerial(Year(data2), Month(data1), Day(data1)) > data2 Then
        anni = anni - 1
    End If

    ' --------------------------
    ' Modified Month & Day Calculation
    ' --------------------------
    ' Calculate date after adding full years
    tempDate = DateSerial(Year(data1) + anni, Month(data1), Day(data1))

    ' Calculate months difference
    mesi = Month(data2) - Month(tempDate)
    ' Adjust if day of data2 is earlier than day of tempDate
    If Day(data2) < Day(tempDate) Then
        mesi = mesi - 1
    End If

    ' Handle negative months (edge case protection)
    If mesi < 0 Then
        mesi = mesi + 12
        anni = anni - 1
        tempDate = DateSerial(Year(tempDate) - 1, Month(tempDate), Day(tempDate))
    End If

    ' Calculate target year and month after adding full months
    Dim targetYear As Integer, targetMonth As Integer
    targetYear = Year(tempDate)
    targetMonth = Month(tempDate) + mesi
    If targetMonth > 12 Then
        targetYear = targetYear + 1
        targetMonth = targetMonth - 12
    End If

    ' Adjust tempDate to valid date in target month
    If Day(tempDate) > DaysInMonth(targetYear, targetMonth) Then
        ' Use last day of target month if original day is invalid
        tempDate = DateSerial(targetYear, targetMonth + 1, 0)
    Else
        tempDate = DateSerial(targetYear, targetMonth, Day(tempDate))
    End If

    ' Calculate remaining days directly (VBA date subtraction gives day count)
    giorni = data2 - tempDate
    ' --------------------------
    ' End of Modified Code
    ' --------------------------

    ' Construct output strings
    If anni <> 1 Then
        anniStr = " anni"
    Else
        anniStr = " anno"
    End If

    If mesi <> 1 Then
        mesiStr = " mesi"
    Else
        mesiStr = " mese"
    End If

    If giorni <> 1 Then
        giorniStr = " giorni"
    Else
        giorniStr = " giorno"
    End If

    If anni = 0 And mesi = 0 And giorni = giorni_totali Then
        giorni_totaliStr = ""
    Else
        giorni_totaliStr = " (" & CStr(Format(giorni_totali, "#,###")) & " giorni totali)"
    End If

    ' Return requested output
    Select Case dato_richiesto
        Case "anni"
            DiffDate44 = anni
        Case "mesi"
            DiffDate44 = mesi
        Case "giorni"
            DiffDate44 = giorni
        Case "giorni_totali"
            DiffDate44 = giorni_totali
        Case "stringa1"
            DiffDate44 = mesi & mesiStr & ", " & giorni & giorniStr
        Case "stringa2"
            DiffDate44 = mesi & mesiStr & ", " & giorni & giorniStr & giorni_totaliStr
        Case "nascondi_valori_a_zero"
            If anni > 1 Then
                anniStr = CStr(anni) & " anni"
                If mesi > 1 Or giorni > 1 Then
                    spaziatura = ", "
                End If
            ElseIf anni = 1 Then
                anniStr = CStr(anni) & " anno"
                If mesi >= 1 Or giorni >= 1 Then
                    spaziatura = ", "
                End If
            Else
                anniStr = ""
                spaziatura = ""
            End If

            anniStr = anniStr & spaziatura

            If mesi > 1 Then
                mesiStr = CStr(mesi) & " mesi"
                If giorni >= 1 Then
                    spaziatura = ", "
                End If
            ElseIf mesi = 1 Then
                mesiStr = CStr(mesi) & " mese"
                If giorni >= 1 Then
                    spaziatura = ", "
                End If
            Else
                mesiStr = ""
                spaziatura = ""
            End If

            mesiStr = mesiStr & spaziatura

            If giorni > 1 Then
                giorniStr = CStr(giorni) & " giorni"
            ElseIf giorni = 1 Then
                giorniStr = CStr(giorni) & " giorno"
            Else
                giorniStr = ""
            End If

            DiffDate44 = Trim(CStr(anniStr & mesiStr & giorniStr & giorni_totaliStr))
            If DiffDate44 = "" Then DiffDate44 = "nessuna"
        Case "stringa3"
            DiffDate44 = anni & anniStr & ", " & mesi & mesiStr & ", " & giorni & giorniStr
        Case "stringa4"
            DiffDate44 = anni & anniStr & ", " & mesi & mesiStr & ", " & giorni & giorniStr & giorni_totaliStr
        Case "prossimo_compleanno"
            DiffDate44 = data2 & " (" & Giorno_Settimana(data2) & ")"
    End Select

    Exit Function

ErrorHandler:
    MsgBox "Invalid date format. Please enter valid dates."
    DiffDate44 = "ERRORE Invalid Date"

End Function

测试验证 #

• 案例1：31/03/1955与26/05/2024 → 69年、1个月、26天，总天数25,259天
• 案例2：30/03/1955与26/05/2024 → 69年、1个月、27天，总天数25,260天
  结果与Wolfram Alpha完全一致。

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