Question

我有一些问题，在net..dias（天）和taxas（rate）中找到的spline函数是我的电子表格的两个数组，而T是我想要知道相应比率的天数。当我使用这个函数设置函数内部的数组时效果很好......但是使用电子表格的数组，VBA让我很伤心，无法找到项目或库..有人可以帮助我吗？谢谢

 Function NDF6(T, dias, taxas)
 Dim x As Variant
 x = T
 Dim xin() As Variant
 Dim yin() As Variant
 Dim input_count As Integer
 Dim output_count As Integer
 input_count = dias.Count
 output_count = taxas.Count

ReDim xin(input_count)
ReDim yin(output_count)
Dim c As Integer
For c = 1 To input_count
  xin(c) = dias(c)
  yin(c) = taxas(c)
Next c

          'values are populated

  Dim n As Integer 'n=input_count
 Dim i, k As Integer 'these are loop counting integers
 Dim p, qn, sig, un As Variant
 Dim u() As Variant
 ReDim u(input_count - 1) As Variant
 Dim yt() As Variant 'these are the 2nd deriv values
 ReDim yt(output_count - 1) As Variant
 Dim y As Double

  n = input_count
  yt(1) = 0
  u(1) = 0
 For i = 2 To n - 1
 sig = (xin(i) - xin(i - 1)) / (xin(i + 1) - xin(i - 1))
 p = sig * yt(i - 1) + 2
 yt(i) = (sig - 1) / p
  u(i) = (yin(i + 1) - yin(i)) / (xin(i + 1) - xin(i)) - (yin(i) - yin(i - 1)) / (xin(i) - xin(i _  - 1))
  u(i) = (6 * u(i) / (xin(i + 1) - xin(i - 1)) - sig * u(i - 1)) / p

  Next i

  qn = 0
  un = 0
  yt(n) = (un - qn * u(n - 1)) / (qn * yt(n - 1) + 1)
  For k = n - 1 To 1 Step -1
    yt(k) = yt(k) * yt(k + 1) + u(k)
  Next k

  'now eval spline at one point

   Dim klo, khi As Integer
   Dim h, b, a As Single
   ' first find correct interval
   klo = 1
   khi = n
   Do
    k = khi - klo
    If xin(k) > x Then
      khi = k
    Else
      klo = k
   End If
   k = khi - klo
   Loop While k > 1
   h = xin(khi) - xin(klo)
    a = (xin(khi) - x) / h
   b = (x - xin(klo)) / h
   y = a * yin(klo) + b * yin(khi) + ((a ^ 3 - a) * yt(klo) + (b ^ 3 - b) * yt(khi)) * (h ^ 2) / _ 6

    NDF6 = y

    End Function

Answer 1

您可以使用我的代码：

Excel

工作表计算如下：

Public Sub TestSpline()

    Dim x() As Variant, y() As Variant, ypp() As Variant
    Dim xe() As Variant, ye() As Variant

    x = [B2].Resize(13, 1).Value
    y = [C2].Resize(13, 1).Value
    xe = [N2].Resize(49, 1).Value

    CalculateYpp x, y, ypp
    CalculatePoints x, y, ypp, xe, ye

    [O2].Resize(49, 1).Value = ye

End Sub

和 Cubic Spline 计算完成：

Public Sub CalculateYpp(ByRef x() As Variant, ByRef y() As Variant, ByRef ypp() As Variant, Optional dydx_1 As Variant = vbNullString, Optional dydx_N As Variant = vbNullString)

    Dim N As Integer, Z As Integer
    'calculate 2nd derivatives
    N = UBound(x, 1): Z = UBound(y, 2)
    ReDim ypp(1 To N, 1 To Z)

    Dim u() As Variant
    ReDim u(1 To N, 1 To Z)
    Dim i As Integer
    For i = 1 To Z
        If Not IsNumeric(dydx_1) Then
            ypp(1, i) = 0#
            u(1, i) = 0#
        Else
            ypp(1, i) = -0.5
            u(1, i) = 3# / (x(2, 1) - x(1, 1)) * ((y(2, i) - y(1, i)) / (x(2, 1) - x(1, 1)) - CDbl(dydx_1))
        End If

        Dim k As Integer
        Dim sig As Variant
        Dim P As Variant, hn As Variant, hi As Variant
        For k = 2 To N - 1 Step 1
            hi = x(k, 1) - x(k - 1, 1)
            hn = x(k + 1, 1) - x(k, 1)
            sig = hi / (hn + hi)
            P = sig * ypp(k - 1, 1) + 2#
            ypp(k, i) = (sig - 1#) / P
            If Abs(hn) > 0 And Abs(hi) > 0 Then
                u(k, i) = (6# * ((y(k + 1, i) - y(k, i)) / hn - (y(k, i) - y(k - 1, i)) / hi) _
                        / (hn + hi) - sig * u(k - 1, i)) / P
            ElseIf Abs(hi) > 0 Then
                u(k, i) = (6# * (-(y(k, i) - y(k - 1, i)) / hi) / (hn + hi) - sig * u(k - 1, i)) / P
            ElseIf Abs(hn) > 0 Then
                u(k, i) = (6# * ((y(k + 1, i) - y(k, i)) / hn) / (hn + hi) - sig * u(k - 1, i)) / P
            Else
                u(k, i) = -sig * u(k - 1, i) / P
            End If
        Next k
        Dim qn As Variant
        If Not IsNumeric(dydx_N) Then
            qn = 0#
            u(N, i) = 0#
        Else
            qn = 0.5
            u(N, i) = 3# / (x(N, 1) - x(N - 1, 1)) * (CDbl(dydx_N) - (y(N, i) - y(N - 1, i)) / _
                            (x(N, 1) - x(N - 1, 1)))
        End If
        ypp(N, i) = (u(N, i) - qn * u(N - 1, i)) / (qn * ypp(N - 1, i) + 1#)
        For k = N - 1 To 1 Step -1
            ypp(k, i) = ypp(k, i) * ypp(k + 1, i) + u(k, i)
        Next k

    Next i 'Next Column

End Sub

Public Function IndexOf(ByRef x() As Variant, ByVal x_value As Variant) As Integer
    Dim K1 As Integer, K2 As Integer, k As Integer, N As Integer
    N = UBound(x, 1)
    'Do bisection to find index of xi()
    K1 = 1
    K2 = N
    Do While (K2 - K1) > 1
        k = (K1 + K2) / 2
        If (x(K1, 1) - x_value) * (x(k, 1) - x_value) <= 0 Then
            K2 = k
        Else
            K1 = k
        End If
    Loop
    k = K1
    If k > N - 1 Then k = N - 1

    IndexOf = k
End Function

Public Sub CalculatePoints(ByRef x() As Variant, ByRef y() As Variant, ByRef ypp() As Variant, ByRef xe() As Variant, ByRef ye() As Variant)
    Dim i As Integer, k As Integer, K1 As Integer
    Dim N As Integer, Z As Integer
    N = UBound(xe, 1): Z = UBound(y, 2)
    ReDim ye(1 To N, 1 To Z)

    Dim x1 As Variant, y1 As Variant, y1pp As Variant
    Dim x2 As Variant, y2 As Variant, y2pp As Variant
    Dim A As Variant, b As Variant, h As Variant, C As Variant, D As Variant

    For i = 1 To Z
        For k = 1 To N
            K1 = IndexOf(x, xe(k, 1))
            x1 = x(K1, 1)
            x2 = x(K1 + 1, 1)
            y1 = y(K1, i)
            y2 = y(K1 + 1, i)
            y1pp = ypp(K1, i)
            y2pp = ypp(K1 + 1, i)
            h = x2 - x1
            A = (x2 - xe(k, 1)) / h
            b = (xe(k, 1) - x1) / h
            C = (A * A * A - A) * h ^ 2 / 6#
            D = (b * b * b - b) * h ^ 2 / 6#

            ye(k, i) = y1 * A + y2 * b + y1pp * C + y2pp * D
        Next k
    Next i
End Sub

它甚至适用于y和ye的多个列。

为什么我的样条函数不起作用？

1 个答案: