Question

我有一个名为＆＃34; CurveInterpolateRecordset＆＃34;的函数，如下所示：

Function CurveInterpolateRecordset(rsCurve As Recordset, InterpDate As Date) As Double

    Dim I As Long

    Dim x1 As Date, x2 As Date, y1 As Double, y2 As Double, x As Date
    CurveInterpolateRecordset = Rnd()
    If rsCurve.RecordCount <> 0 Then

        I = 1
        rsCurve.MoveFirst

        x1 = CDate(rsCurve.Fields("MaturityDate"))
        y1 = CDbl(rsCurve.Fields("ZeroRate"))
        If InterpDate = CDate(rsCurve.Fields("MaturityDate")) Then CurveInterpolateRecordset = CDbl(rsCurve.Fields("ZeroRate")): Exit Function
        'Do While Not rsCurve.EOF
        rsCurve.MoveNext
        Do While (CDate(rsCurve.Fields("MaturityDate")) <= InterpDate)
            If rsCurve.EOF Then CurveInterpolateRecordset = CDbl(rsCurve.Fields("ZeroRate")): Exit Function

            If InterpDate = CDate(rsCurve.Fields("MaturityDate")) Then CurveInterpolateRecordset = CDbl(rsCurve.Fields("ZeroRate")): Exit Function

            If InterpDate > CDate(rsCurve.Fields("MaturityDate")) Then

            x1 = CDate(rsCurve.Fields("MaturityDate"))
            y1 = CDbl(rsCurve.Fields("ZeroRate"))

            End If

            rsCurve.MoveNext
            If rsCurve.EOF Then CurveInterpolateRecordset = y1: Exit Function

        Loop

            x2 = CDate(rsCurve.Fields("MaturityDate"))
            y2 = CDbl(rsCurve.Fields("ZeroRate"))

            CurveInterpolateRecordset = y1 + (y2 - y1) * CDate((InterpDate - x1) / (x2 - x1))
    End If


        Debug.Print I, InterpDate, x1, x2, y1, y2
End Function

此循环将通过使用最近日期的值进行插值来插入特定日期的缺失值。

我有一个日期表，其中一些需要插值，所以我使用另一个函数迭代记录集并将函数传递给每个记录的相应日期以便插值。

Sub SampleReadCurve()

Dim rs As Recordset
Dim iRow As Long, iField As Long
Dim strSQL As String
Dim CurveID As Long
Dim MarkRunID As Long
Dim ZeroCurveID As String

CurveID = 124
MarkRunID = 10167
ZeroCurveID = "'" & CurveID & "-" & MarkRunID & "'"
'strSQL = "SELECT * FROM dbo_VolatilityInput WHERE ZeroCurveID='124-10167'"
strSQL = "SELECT * FROM dbo_VolatilityInput WHERE ZeroCurveID=" & ZeroCurveID & " ORDER BY MaturityDate"
Set rs = CurrentDb.OpenRecordset(strSQL, Type:=dbOpenDynaset, Options:=dbSeeChanges)



If rs.RecordCount <> 0 Then

Do While Not rs.EOF

    rs.MoveFirst
    Debug.Print vbCrLf
    Debug.Print "First", rs!ZeroCurveID, rs!MaturityDate, rs!ZeroRate, rs!DiscountFactor
    rs.MoveLast
    Debug.Print "Last", rs!ZeroCurveID, rs!MaturityDate, rs!ZeroRate, rs!DiscountFactor
    Debug.Print "There are " & rs.RecordCount & " records and " _
                             & rs.Fields.Count & " fields."

    Dim BucketTermAmt As Long
    Dim BucketTermUnit As String
    Dim BucketDate As Date
    Dim MarkAsOfDate As Date
    Dim InterpRate As Double
    MarkAsOfDate = rs!MarkAsOfDate
    BucketTermAmt = 3
    BucketTermUnit = "m"
    BucketDate = DateAdd(BucketTermUnit, BucketTermAmt, MarkAsOfDate)
    InterpRate = CurveInterpolateRecordset(rs, BucketDate)
    Debug.Print BucketDate, InterpRate



   rs.MoveNext

Loop

   End If

End Sub

对于一个单独的记录和日期，第一个功能正常。但是，当我执行第二个函数时，循环会无限重复并且程序崩溃。我不明白为什么会发生这种情况，因为在第二个循环中显然存在结束条件。记录集只有76条记录，因此不是很大。

Answer 1

从rs.MoveFirst循环中删除以rs.MoveLast开头并以while结尾的块。它们应位于if内但在while之前。

循环不会在Access VBA中终止

1 个答案: