Полная стоимость кредита(займа) – пример/алгоритм расчета

    Public summa()
    Public e()
    Public q()
    Public m As Integer
    
Sub Кнопка1_Щелчок()
    Dim dates()
    Columns("A:A").Select
    dates() = Application.Transpose(Range(ActiveCell, Cells(Rows.Count, ActiveCell.Column).End(xlUp)))

    Columns("B:B").Select
    summa = Application.Transpose(Range(ActiveCell, Cells(Rows.Count, ActiveCell.Column).End(xlUp)))
    
    m = UBound(dates)
    
    'Считаем интервалы БП по графику
    ReDim BPall(m)
    For k = 3 To m
        BPall(k) = dates(k) - dates(k - 1)
    Next
    'подсчитываем частотность - 1000 это максимальный временной период между платежами в графике
    Dim Freq(1000) As Integer
    For k = 1 To 1000
        Freq(k) = 0
    Next
    For k = 3 To m
        Freq(BPall(k)) = Freq(BPall(k)) + 1
    Next
    'получаем период с самой наибольшей частотой
    mmax = Freq(1)
    For k = 1 To 1000
      If mmax < Freq(k) Then mmax = Freq(k)
    Next k
    'берем с наименьшим БП, если одинаковая частотность
    bpmin = 1000
    For k = 1 To 1000
      If mmax = Freq(k) And k < bpmin Then bpmin = k
    Next k
    
    'определяем Базовый период
    bp = (bpmin)
    cbp = Round(365 / bp)
    
    ReDim Days(m)
    For k = 2 To m
        Days(k) = dates(k) - dates(2)
    Next
    
    ReDim e(m)
    ReDim q(m)
    
    For k = 2 To m
        q(k) = Days(k) \ bp
        e(k) = (Days(k) Mod bp) / bp
    Next
    
    Dim r  As Double
    r = 0
    Bisect 0, 10000, 0.000000000000001, r
    
    psk = Round(r * cbp, 5)
    Cells(3, 7).Value = psk
    
End Sub

Function F(w As Double) As Double
Dim x As Double
        x = 0
        For k = 2 To m
            x = x + summa(k) / ((1 + e(k) * w) * ((1 + w) ^ q(k)))
        Next
        F = x
End Function

Sub Bisect(ByVal a As Double, ByVal b As Double, ByVal eps As Double, ByRef r As Double)
Dim c  As Double
Dim fa As Double
Dim fb As Double
Dim fc As Double
    fa = F(a)
    fb = F(b)
     Do
      c = 0.5 * (a + b)
      If Abs(a - b) <= eps Then
         r = c
         Exit Sub
      End If
      fc = F(c)
      If Abs(fa) <= eps Then
         r = a
         Exit Sub
      End If
      If Abs(fb) <= eps Then
         r = a
         Exit Sub
      End If
      If (fc > 0 And fb < 0) Or _
         (fc < 0 And fb > 0) Then
         a = c
         fa = F(a)
      Else
         b = c
         fb = F(b)
      End If
    Loop
End Sub