• Home
 · 
• Miscellaneous
 · 
• Better version of Compute Duration (Can be used in MS Access too)

Better version of Compute Duration (Can be used in MS Access too)

Better version of Compute Duration (Can be used in MS Access too)

Rate Better version of Compute Duration (Can be used in MS Access too)

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'Function Rounding of Number by Cyrus - Biohazard
Public Function RoundNo(fltValue As Variant, intDecimalPlaces As Integer) As Double
On Error GoTo RoundNoErr
Dim strValue$, strValue2$, intstrValuelength%, intNextValue%, strValuetoAdd$, intValLength%, ix%

    strValue$ = CStr(Val(fltValue))
    intValLength% = intDecimalPlaces + 2
    
    If intDecimalPlaces = 0 Then
        Dim intFixValue%
        
        intFixValue% = Fix(Val(fltValue))
        strValue2$ = Mid(strValue$, 3)
        If Val(Mid(strValue2$, 1, 1)) >= 5 Then
            RoundNo = intFixValue% + 1
        Else
            RoundNo = intFixValue%
        End If
        Exit Function
    ElseIf (intValLength% = Len(strValue$)) Or _
        (strValue$ = "0.0" Or strValue$ = "0") Or _
        (intDecimalPlaces < 0) Then
        strValue2$ = strValue$
        GoTo ReturnTheSameValue
    End If
        
    strValue2$ = Mid(strValue$, 1, intValLength%)
    intNextValue% = Val(Mid(strValue$, intValLength% + 1, 1))
    
    If intNextValue% >= 5 Then
        intstrValuelength% = Len(strValue2$)
        
        strValuetoAdd$ = "0."
        For ix = 3 To intstrValuelength%
            If ix = intstrValuelength% Then Exit For
            strValuetoAdd$ = strValuetoAdd$ & "0"
        Next
        strValuetoAdd$ = strValuetoAdd$ & "1"
        
        RoundNo = CDbl(strValue2$) + CDbl(strValuetoAdd$)
    Else
        GoTo ReturnTheSameValue
    End If
    Exit Function
    
ReturnTheSameValue:

    RoundNo = CDbl(strValue2$)
    Exit Function
    
RoundNoErr:
    RoundNo = 0
End Function

Public Function GetPeriodDesired(strValue$, lngToGet As Long, Optional blnLeap As Boolean = True) As Variant
Dim intMonth%, intDays%, varResult As Variant

'strValue$ = CStr(varValue)
If InStr(1, strValue$, ".") > 0 Then
    intMonth% = Val(Mid(strValue$, 1, InStr(1, strValue$, ".") - 1))
    intDays% = Val(Mid(strValue$, InStr(1, strValue$, ".") + 1))
Else
    intMonth% = Val(strValue$)
End If

'Possible Result
Select Case lngToGet
    Case 1 'Y      - Year(s) Only
        varResult = Fix(intMonth% / 12)
    Case 2 'Y.M    - Year(s).Month(s) Only
        varResult = Fix(intMonth% / 12) & "." & intMonth% - (Fix(intMonth% / 12) * 12)
    Case 3 'M      - Month(s) Only
        varResult = intMonth%
    Case 4 'M.D    - Month(s).Day(s) Only
        varResult = intMonth% & "." & intDays%
    Case 5 'D      - Day(s) Only
        varResult = Val(IIf(blnLeap = True, RoundNo((intMonth% / 12), 0) * 366, RoundNo((intMonth% / 12), 0) * 365)) + intDays%
End Select
GetPeriodDesired = varResult

End Function

'Brought to you by Cyrus aka Biohazard
Public Function GetActualPeriodDiffByCyAccurate(dStart As Date, dEnd As Date, lngToGet As Long, Optional blnLeap As Boolean = True) As String
Dim intNoOfDays%, intDaysPerMonthoftheYear%(12), _
    intDStartMonth%, intDEndMonth%, intYearDiff%, _
    dblTotalMonthsNDays#, _
    ix%, intDaysRemaining%, _
    intMontConsumed%
    
    If (IsNull(dStart) Or IsNull(dEnd)) Or dStart > dEnd Then
        GetActualPeriodDiffByCyAccurate = "0.0"
        Exit Function
    End If
    
    'Tracing of TNoDays in Year of dStart
    intDaysPerMonthoftheYear%(1) = 31
    intDaysPerMonthoftheYear%(2) = IIf(DateDiff("d", CDate("1/1/" & Year(dStart)), CDate("12/31/" & Year(dStart))) = 365, 29, 28)
    intDaysPerMonthoftheYear%(3) = 31
    intDaysPerMonthoftheYear%(4) = 30
    intDaysPerMonthoftheYear%(5) = 31
    intDaysPerMonthoftheYear%(6) = 30
    intDaysPerMonthoftheYear%(7) = 31
    intDaysPerMonthoftheYear%(8) = 31
    intDaysPerMonthoftheYear%(9) = 30
    intDaysPerMonthoftheYear%(10) = 31
    intDaysPerMonthoftheYear%(11) = 30
    intDaysPerMonthoftheYear%(12) = 31
        
    intDStartMonth% = Month(dStart)
    intDEndMonth% = Month(dEnd)
    intYearDiff% = DateDiff("yyyy", dStart, dEnd)
    
    If intYearDiff% > 0 Then
        'Recursive
        For ix% = 0 To intYearDiff%
            If ix% <> intYearDiff% Then
                dblTotalMonthsNDays# = dblTotalMonthsNDays# + Val(GetActualPeriodDiffByCyAccurate(dStart, CDate("12/31/" & Year(dStart) + ix%), 4))
            Else
                Dim strLastNumValue$, strGenVal$
                strGenVal$ = GetActualPeriodDiffByCyAccurate(CDate("1/1/" & Year(dEnd)), dEnd, 4)
                strLastNumValue$ = strGenVal$
                dblTotalMonthsNDays# = dblTotalMonthsNDays# + CDbl(strGenVal$)

                If Len(strLastNumValue$) = 4 Then
                    strLastNumValue$ = Mid(strLastNumValue$, Len(strLastNumValue$))
                End If
            End If
        Next
        
        GetActualPeriodDiffByCyAccurate = GetPeriodDesired(CStr(dblTotalMonthsNDays#), lngToGet, blnLeap) & IIf(strLastNumValue$ = "0", "0", "")
        
        
    ElseIf intYearDiff% = 0 Then
        If intDStartMonth% = intDEndMonth% Then
            intNoOfDays% = DateDiff("d", dStart, dEnd) + 1
            If intNoOfDays% = intDaysPerMonthoftheYear%(intDStartMonth%) Then
                GetActualPeriodDiffByCyAccurate = GetPeriodDesired("1", lngToGet, blnLeap)
            Else
                GetActualPeriodDiffByCyAccurate = GetPeriodDesired(intMontConsumed% & "." & (DateDiff("d", dStart, dEnd + 1)), lngToGet, blnLeap)
            End If
            Exit Function
        ElseIf intDStartMonth% <> intDEndMonth% Then
            intNoOfDays% = DateDiff("d", dStart, dEnd) + 1
            For ix% = intDStartMonth% To intDEndMonth%
                If intNoOfDays% >= intDaysPerMonthoftheYear%(ix%) Then
                    intMontConsumed% = intMontConsumed% + 1
                    intNoOfDays% = intNoOfDays% - intDaysPerMonthoftheYear%(ix%)
                Else
                    intDaysRemaining% = intNoOfDays%
                End If
            Next
            GetActualPeriodDiffByCyAccurate = GetPeriodDesired(CStr(intMontConsumed%) & "." & CStr(intDaysRemaining%), lngToGet, blnLeap)
        End If
    End If
    
End Function