VBA 2000年之后活期存款利息计算

本例为工作中特殊需要，非银行给付利息方式：

Private Function CDI_Rate1000(ByVal Year As Integer) As Long
'{1,2,7,8,11,12},{99,72,81,36,50,35}
Dim Rate As Single
Select Case (Year - 2000)
    Case Is < 0:
        Rate = 0
    Case 0 To 1:
        Rate = 0.99
    Case 2 To 6:
        Rate = 0.72
    Case 7:
        Rate = 0.81
    Case 8 To 10:
        Rate = 0.36
    Case 11:
        Rate = 0.5
    Case Is >= 12
        Rate = 0.35
End Select
CDI_Rate1000 = Rate * 1000
End Function

Private Function TDI_Rate1000(ByVal Year As Integer) As Long
'{1,3,5,7,8,9,10,11,12,13,15,16}
'{2.25,1.98,2.25,2.52,4.14,2.52,2.25,2.5,3.5,3,2.75,1.5}
Dim Rate As Single
Select Case (Year - 2000)
    Case Is < 0:
        Rate = 0
    Case 0 To 2:
        Rate = 2.25
    Case 3 To 4:
        Rate = 1.98
    Case 5 To 6:
        Rate = 2.25
    Case 7:
        Rate = 2.52
    Case 8:
        Rate = 4.14
    Case 9:
        Rate = 2.52
    Case 10:
        Rate = 2.25
    Case 11:
        Rate = 2.5
    Case 12:
        Rate = 3.5
    Case 13 To 14:
        Rate = 3.2
    Case 15:
        Rate = 2.75
    Case Is >= 16
        Rate = 1.5
End Select
TDI_Rate1000 = Rate * 1000
End Function

Private Function DaysR(ByVal ymd As Date) As Integer '某一天到该年底的天数（含此日）
    DaysR = DateSerial(Year(ymd), 12, 31) - ymd + 1
End Function

Private Function DaysL(ByVal ymd As Date) As Integer '一年中某日之前的天数（不含此日）
    DaysL = ymd - DateSerial(Year(ymd), 1, 1)
End Function

Private Function Leap(ByVal Y As Integer) As Boolean
    Leap = (Y Mod 4 = 0 And Y Mod 100 <> 0) Or (Y Mod 400 = 0)
End Function

Private Function VtoD(ByVal vDate As Variant) As Variant
Dim Y, M, D As Integer
VtoD = True
Select Case VarType(vDate)
    Case 0 To 2, Is = 6, Is > 8
        VtoD = False
    Case 3 To 5
        VtoD = VtoD(CStr(vDate))
    Case 7:
        VtoD = Format(vDate, "yyyy-mm-dd")
        If VtoD < "2000-01-01" Then VtoD = False
    Case 8:
        If Len(vDate) <> 8 Then
            VtoD = False
            Exit Function
        End If
        For i = 1 To 8
            If Asc(Mid(vDate, i, 1)) < 48 Or Asc(Mid(vDate, i, 1)) > 57 Then
                VtoD = False
                Exit Function
            End If
        Next
        Y = --Left(vDate, 4): M = --Mid(vDate, 5, 2): D = --Right(vDate, 2)
        If Y < 2000 Then VtoD = False
        If M > 12 Or M = 0 Then VtoD = False
        If D > 31 Or D = 0 Then VtoD = False
        If M = 2 And D > (28 + IIf(Leap(Y), 1, 0)) Then VtoD = False
        If VtoD = False Then Exit Function
        VtoD = Format(DateSerial(Y, M, D), "yyyy-mm-dd")
End Select
End Function

Private Function CDInterest(ByVal Amounts As Double, ByVal vDate As Variant, Optional R As Boolean = False) As Double
Dim dRate As Double
vDate = VtoD(vDate)
CDInterest = 0
If vDate = False Then
    MsgBox "日期格式错！"
    Exit Function
End If
If R Then
    CDInterest = Round(Amounts, 2) * CDI_Rate1000(Year(vDate)) / 1000 / 100 / 365 * DaysR(vDate)
Else
    CDInterest = Round(Amounts, 2) * CDI_Rate1000(Year(vDate)) / 1000 / 100 / 365 * DaysL(vDate)
End If
End Function