Excel 线性插值 VBA

Question

此函数 interpolates/extrapolates 已知 x,y 的 table 例如，

Linterp(A1:B3, -1) = 0

但是这段代码只能做两个相邻的数组。我想修改这段代码，这样我就可以 select 两个单独的数组，例如 N106:N109,P106:P109。如何在此代码中进行此调整？

Function Linterp(r As Range, x As Double) As Double
     ' linear interpolator / extrapolator
     ' R is a two-column range containing known x, known y
    Dim lR As Long, l1 As Long, l2 As Long
    Dim nR As Long
     'If x = 1.5 Then Stop

    nR = r.Rows.Count
    If nR < 2 Then Exit Function

    If x < r(1, 1) Then ' x < xmin, extrapolate
        l1 = 1: l2 = 2: GoTo Interp

    ElseIf x > r(nR, 1) Then ' x > xmax, extrapolate
        l1 = nR - 1: l2 = nR: GoTo Interp

    Else
         ' a binary search would be better here
        For lR = 1 To nR
            If r(lR, 1) = x Then ' x is exact from table
                Linterp = r(lR, 2)
                Exit Function

            ElseIf r(lR, 1) > x Then ' x is between tabulated values, interpolate
                l1 = lR: l2 = lR - 1: GoTo Interp

            End If
        Next
    End If

Interp:
    Linterp = r(l1, 2) _
    + (r(l2, 2) - r(l1, 2)) _
    * (x - r(l1, 1)) _
    / (r(l2, 1) - r(l1, 1))

End Function

Answer 1

一种非常简单的方法是让函数接受两个输入范围，一个用于 X 值（例如 rX），一个用于 Y 值（例如 rY），然后将每次出现的 r(foo,1) 更改为 rX(foo) 和 r(foo,2) 到 rY(foo)

喜欢关注

Option Explicit

Function Linterp2(rX As Range, rY As Range, x As Double) As Double
     ' linear interpolator / extrapolator
     ' R is a two-column range containing known x, known y
    Dim lR As Long, l1 As Long, l2 As Long
    Dim nR As Long
     'If x = 1.5 Then Stop

    nR = rX.Rows.Count
    If nR < 2 Then Exit Function

    If x < rX(1) Then ' x < xmin, extrapolate
        l1 = 1: l2 = 2: GoTo Interp

    ElseIf x > rX(nR) Then ' x > xmax, extrapolate
        l1 = nR - 1: l2 = nR: GoTo Interp

    Else
         ' a binary search would be better here
        For lR = 1 To nR
            If rX(lR) = x Then ' x is exact from table
                Linterp2 = rY(lR)
                Exit Function

            ElseIf rX(lR) > x Then ' x is between tabulated values, interpolate
                l1 = lR: l2 = lR - 1: GoTo Interp

            End If
        Next
    End If

Interp:
    Linterp2 = rY(l1) _
    + (rY(l2) - rY(l1)) _
    * (x - rX(l1)) _
    / (rX(l2) - rX(l1))

End Function

但您必须实施代码来检查两个范围的一致性，例如每个范围都是一列并且行数相同

Answer 2

使用此功能：

Public Function lineare_iterpolation(x As Variant, x1 As Variant, x2 As Variant, y1 As Variant, y2 As Variant) As Variant
    If x = x1 Then
        lineare_iterpolation = y1
        Exit Function
    End If
    If x = x2 Then
        lineare_iterpolation = y2
        Exit Function
    End If
    lineare_iterpolation = y1 + (x - x1) * (y2 - y1) / (x2 - x1)
    Exit Function
End Function

Excel 线性插值 VBA

Excel Linear Interpolation VBA

excel

interpolation

vba

linear-interpolation