math - 将 10 个周期的曲线折叠为 4 个周期

Question

下面有一个 10 期成本曲线表。我如何以编程方式将其折叠/压缩/缩小为 4 个周期。我正在使用 VBA，但我应该能够使用其他语言。该例程应该在您传递给它的任何时间段内工作。例如，如果我将 7 传递给它，它应该将百分比压缩为 7 个句点。如果我通过 24，则将百分比扩展到 24 个周期，根据原始曲线展开百分比。任何帮助或示例将不胜感激。谢谢...

ORIGINALPeriod  Pct1       10.60%2       19.00%3       18.30%4       14.50%5       10.70%6        8.90%7        6.50%8        3.10%9        3.00%10       5.40%

COLLAPSEDPeriod  Pct1       38.75%2       34.35%3       16.95%4        9.95%

已编辑:我已经在下面添加了关于我目前所拥有的示例代码。它只适用于第 1、2、3、5、9、10 个时间段。也许有人可以帮助修改它以在任何时间段工作。免责声明，我不是程序员，所以我的编码很糟糕。另外，我不知道自己在做什么。

Sub Collapse_Periods()    Dim aPct As Variant    Dim aPer As Variant    aPct = Array(0.106, 0.19, 0.183, 0.145, 0.107, 0.089, 0.065, 0.031, 0.03, 0.054)    aPer = Array(1, 2, 3, 5, 9, 10)    For i = 0 To UBound(aPer)        pm = 10 / aPer(i)        pct1 = 1        p = 0        ttl = 0        For j = 1 To aPer(i)            pct = 0            k = 1            Do While k <= pm                pct = pct + aPct(p) * pct1                pct1 = 1                p = p + 1                If k <> pm And k = Int(pm) Then                    pct1 = (pm - Int(pm)) * j                    pct = pct + (pct1 * aPct(p))                    pct1 = 1 - pct1                End If                k = k + 1            Loop            Debug.Print aPer(i) & " : " & j & " : " & pct            ttl = ttl + pct        Next j        Debug.Print "Total:  " & ttl    Next iEnd Sub

Answer 1

我想知道这也是如何使用 Integral 完成的？这就是我的做法 - 也许这是一种普通的/长篇大论的方法，但我希望看到一些更好的建议。

首先使用 LINEST 函数和命名范围在 Excel 中查看该方法可能更容易。我假设函数是对数的。我概述了步骤 [1.] - [5.]

此 VBA 代码基本上复制了 Excel 方法，使用一个函数传递 2 个数组、句点和一个可以写入范围的返回数组

Sub CallingProc()
Dim Periods As Long, returnArray() As Variant
Dim X_Values() As Variant, Y_Values() As Variant

Periods = 4
ReDim returnArray(1 To Periods, 1 To 2)

With Sheet1
    X_Values = Application.Transpose(.Range("A2:A11"))
    Y_Values = Application.Transpose(.Range("B2:B11"))
End With


FGraph X_Values, Y_Values, Periods, returnArray 'pass 1D array of X, 1D array of Y,    Periods, Empty ReturnArray
End Sub


Function FGraph(ByVal x As Variant, ByVal y As Variant, ByVal P As Long, ByRef returnArray As Variant)
Dim i As Long, mConstant As Double, cConstant As Double

'calc cumulative Y and take Ln (Assumes Form of Graph is logarithmic!!)
For i = LBound(y) To UBound(y)
    If i = LBound(y) Then
        y(i) = y(i)
    Else
        y(i) = y(i) + y(i - 1)
    End If

    x(i) = Log(x(i))
Next i

'calc line of best fit
With Application.WorksheetFunction
    mConstant = .LinEst(y, x)(1)
    cConstant = .LinEst(y, x)(2)
End With

'redim array to fill for new Periods
ReDim returnArray(1 To P, 1 To 2)

'Calc new periods based on line of best fit
For i = LBound(returnArray, 1) To UBound(returnArray, 1)
    returnArray(i, 1) = UBound(y) / P * i
    If i = LBound(returnArray, 1) Then
        returnArray(i, 2) = (Log(returnArray(i, 1)) * mConstant) + cConstant
    Else
        returnArray(i, 2) = ((Log(returnArray(i, 1)) * mConstant) + cConstant) - _
        ((Log(returnArray(i - 1, 1)) * mConstant) + cConstant)
    End If
Next i

'returnArray can be written to range

End Function

编辑:

此 VBA 代码现在计算新周期减少两侧的点的线性趋势。数据以名为 returnArray 的二维数组形式返回

Sub CallingProc()
Dim Periods As Long, returnArray() As Variant
Dim X_Values() As Variant, Y_Values() As Variant

Periods = 4
ReDim returnArray(1 To Periods, 1 To 2)

With Sheet1
    X_Values = Application.Transpose(.Range("A2:A11"))
    Y_Values = Application.Transpose(.Range("B2:B11"))
End With


FGraph X_Values, Y_Values, returnArray 'pass 1D array of X, 1D array of Y, Dimensioned  ReturnArray
End Sub


Function FGraph(ByVal x As Variant, ByVal y As Variant, ByRef returnArray As Variant)
Dim i As Long, j As Long, mConstant As Double, cConstant As Double, Period As Long

Period = UBound(returnArray, 1)

'calc cumulative Y
For i = LBound(y) + 1 To UBound(y)
        y(i) = y(i) + y(i - 1)
Next i

'Calc new periods based on line of best fit
For i = LBound(returnArray, 1) To UBound(returnArray, 1)
    returnArray(i, 1) = UBound(y) / Period * i

        'find position of new period to return adjacent original data points
        For j = LBound(x) To UBound(x)
          If returnArray(i, 1) <= x(j) Then Exit For
        Next j

        'calc linear line of best fit between existing data points
        With Application.WorksheetFunction
            mConstant = .LinEst(Array(y(j), y(j - 1)), Array(x(j), x(j - 1)))(1)
            cConstant = .LinEst(Array(y(j), y(j - 1)), Array(x(j), x(j - 1)))(2)
        End With

        returnArray(i, 2) = (returnArray(i, 1) * mConstant) + cConstant

Next i

'returnarray holds cumulative % so calc period only %
For i = UBound(returnArray, 1) To LBound(returnArray, 1) + 1 Step -1
    returnArray(i, 2) = returnArray(i, 2) - returnArray(i - 1, 2)
Next i

'returnArray now holds your data

End Function

返回:

折叠

1 38.75%

2 34.35%

3 16.95%

4 9.95%