[源码全公开]让你在论坛发布彩色VBA代码

hhzjxss

      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-8-20 9:55:29
Public Function LinearInterpolation(ary, x0, Optional Num As Integer = 1)
'VBA入门级作品：表格线性插值,wenguoli3
    n = ary.Rows.Count    '统计行数
    m = ary.Columns.Count    '统计列数
    If n <= m Then     '横表
        i = 1
        If Num = 2 Then
            Do While x0 > ary.Cells(2, i).Value And i < m  'x0位于i-1与i列之间
                i = i + 1
            Loop
        Else
            Do While x0 > ary.Cells(1, i).Value And i < m  'x0位于i-1与i列之间
                i = i + 1
            Loop
        End If
        If i = 1 Then     '超出表格左侧
            i = 2
        End If
        '以下判断要求值的x0是在第一列数据中，还是在第二列数据中：
        If Num = 2 Then
            k = (x0 - ary.Cells(2, i - 1).Value) / (ary.Cells(2, i).Value - ary.Cells(2, i - 1).Value)
            LinearInterpolation = ary.Cells(1, i - 1).Value + k * (ary.Cells(1, i).Value - ary.Cells(1, i - 1).Value)
        Else
            k = (x0 - ary.Cells(1, i - 1).Value) / (ary.Cells(1, i).Value - ary.Cells(1, i - 1).Value)
            LinearInterpolation = ary.Cells(2, i - 1).Value + k * (ary.Cells(2, i).Value - ary.Cells(2, i - 1).Value)
        End If
    Else     '竖表
        i = 1
        If Num = 2 Then
            Do While x0 > ary.Cells(i, 2).Value And i < n  'x0位于i-1与i列之间
                i = i + 1
            Loop
        Else
            Do While x0 > ary.Cells(i, 1).Value And i < n  'x0位于i-1与i列之间
                i = i + 1
            Loop
        End If
        If i = 1 Then     '超出表格顶部
            i = 2
        End If
        '以下判断要求值的x0是在第一列数据中，还是在第二列数据中：
        If Num = 2 Then
            k = (x0 - ary.Cells(i - 1, 2).Value) / (ary.Cells(i, 2).Value - ary.Cells(i - 1, 2).Value)
            LinearInterpolation = ary.Cells(i - 1, 1).Value + k * (ary.Cells(i, 1).Value - ary.Cells(i - 1, 1).Value)
        Else
            k = (x0 - ary.Cells(i - 1, 1).Value) / (ary.Cells(i, 1).Value - ary.Cells(i - 1, 1).Value)
            LinearInterpolation = ary.Cells(i - 1, 2).Value + k * (ary.Cells(i, 2).Value - ary.Cells(i - 1, 2).Value)
        End If
    End If
End Function

hhzjxss

OK，测试成功，谢谢！

dsp5000

多谢老朽的无私奉献

zldccmx

原帖由 hhzjxss 于 2009-8-20 10:01 发表
OK，测试成功，谢谢！

哈哈，那个作者，你应该修改成你的ID才是
我不敢掠夺你的成果哦

mafutz

呵呵，不顶实在说不过去。

china047

哈哈,真是好东东!!

yj304

丰富

cango.hu

大神 我佩服啊

xueyuan

支持一下。。。

xiaowang2999

偶像级高手！