Excel线性插值VBA

这个函数插入/外推已知x，y的表格例如，

xy 1 10 2 15 3 20 

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

一个非常简单的方法是让函数接受两个input范围，一个用于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 

但是您必须实现代码以检查两个范围的一致性，例如，每个列都具有相同的行数