解决计算1900/01/01以前年龄问题

lss001

Public Function AgeFunc(stdate As Variant, endate As Variant)
    Dim stvar$, stmon$, stday$, styr$
    Dim endvar$, endmon$, endday$
    Dim endyr$, stmonf%, stdayf%
    Dim styrf%, endmonf%, enddayf%
    Dim endyrf%, years%, fx%


    fx = 0
    stvar = sfunc("/", stdate)
    stmon = Left(stdate, sfunc("/", stdate) - 1)
    stday = Mid(stdate, stvar + 1, sfunc("/", stdate, sfunc("/", stdate) + 1) - stvar - 1)
    If Len(stday) = 1 Then fx = fx + 1
    If Len(stmon) = 2 Then fx = fx + 1
    styr = Right(stdate, Len(stdate) - (sfunc("/", stdate) + 1) - stvar + fx)
    stmonf = CInt(stmon)
    stdayf = CInt(stday)
    styrf = CInt(styr)
    If stmonf < 1 Or stmonf > 12 Or stdayf < 1 Or stdayf > 31 Or styrf < 1 Then
        AgeFunc = "Invalid Date"
        Exit Function
    End If


    fx = 0
    endvar = sfunc("/", endate)
    endmon = Left(endate, sfunc("/", endate) - 1)
    endday = Mid(endate, endvar + 1, sfunc("/", endate, sfunc("/", endate) + 1) - endvar - 1)
    If Len(endday) = 1 Then fx = fx + 1
    If Len(endmon) = 2 Then fx = fx + 1
    endyr = Right(endate, Len(endate) - (sfunc("/", endate) + 1) - endvar + fx)
    endmonf = CInt(endmon)
    enddayf = CInt(endday)
    endyrf = CInt(endyr)
    If endmonf < 1 Or endmonf > 12 Or enddayf < 1 Or enddayf > 31 Or endyrf < 1 Then
        AgeFunc = "Invalid Date"
        Exit Function
    End If


    years = endyrf - styrf
    If stmonf > endmonf Then
        years = years - 1
    End If
If stmonf = endmonf And stdayf > enddayf Then
        years = years - 1
    End If
    If years < 0 Then
        AgeFunc = "Invalid Date"
    Else
        AgeFunc = years
    End If
End Function

Public Function sfunc(x As Variant, y As Variant, Optional z As Variant)
sfunc = Application.WorksheetFunction.Search(x, y, z)
End Function

Sub abc() '使用示例
    Dim startdate, enddate
    startdate = "01/01/1887"
    enddate = "02/02/1945"
    af = AgeFunc(startdate, enddate)
End Sub

lcluck2002

大哥，你这是求助还是分享还是炫技还是保存“云盘”啊？友情提示一下，代码即使再优秀，一个字的注释也没有，后期看起来也费劲，倒不如重新敲。

lss001

做笔记以备份