[Visual Basic] 纯文本查看 复制代码
Public Function Tlookup(Ta As Range, Noc As Double, Nor As Double) As Double
Dim N, m, i, i1, j, j1 As Integer
Dim minr, maxr, minc, maxc, r1, r2 As Single
Dim Ra As Range
Dim ca As Range
N = Ta.Rows.Count - 1
m = Ta.Columns.Count - 1
Set Ra = Ta.Offset(, 1).Resize(1, m)
Set ca = Ta.Offset(1, 0).Resize(N, 1)
Set Ta = Ta.Offset(1, 1).Resize(N, m)
minr = Application.WorksheetFunction.Min(Ra)
maxr = Application.WorksheetFunction.Max(Ra)
Select Case Nor
Case Is <= minr
If Ra.Cells(1, 1).Value = minr Then
i = 1
i1 = 1
End If
If Ra.Cells(1, m).Value = minr Then
i = m
i1 = m
End If
Case Is >= maxr
If Ra.Cells(1, 1).Value = maxr Then
i = 1
i1 = 1
End If
If Ra.Cells(1, m).Value = maxr Then
i = m
i1 = m
End If
Case minr To maxr
i = 0
If Ra.Cells(1, 1).Value < Ra.Cells(1, m).Value Then
While Nor > minr
minr = Ra.Cells(1, i + 1).Value
i1 = i
i = i + 1
Wend
Else
While Nor < maxr
maxr = Ra.Cells(1, i + 1).Value
i1 = i
i = i + 1
Wend
End If
End Select
minc = Application.WorksheetFunction.Min(ca)
maxc = Application.WorksheetFunction.Max(ca)
Select Case Noc
Case Is <= minc
If ca.Cells(1, 1).Value = minc Then
j = 1
j1 = 1
End If
If ca.Cells(N, 1).Value = minc Then
j = N
j1 = N
End If
Case Is >= maxc
If ca.Cells(1, 1).Value = maxc Then
j = 1
j1 = 1
End If
If ca.Cells(N, 1).Value = maxc Then
j = N
j1 = N
End If
Case minc To maxc
j = 0
If ca.Cells(1, 1).Value < ca.Cells(N, 1).Value Then
While Noc > minc
minc = ca.Cells(j + 1, 1).Value
j1 = j
j = j + 1
Wend
Else
While Noc < maxc
maxc = ca.Cells(j + 1, 1).Value
j1 = j
j = j + 1
Wend
End If
End Select
r1 = NS(Ra.Cells(1, i1).Value, Ta.Cells(j1, i1).Value, Ra.Cells(1, i).Value, Ta.Cells(j1, i).Value, Nor)
r2 = NS(Ra.Cells(1, i1).Value, Ta.Cells(j, i1).Value, Ra.Cells(1, i).Value, Ta.Cells(j, i).Value, Nor)
Tlookup = NS(ca.Cells(j1, 1).Value, r1, ca.Cells(j, 1).Value, r2, Noc)
End Function