[romkeris]

Maybe somebody can correct this error?

[Кулик Алексей aka kpblc]

Пробуй:

Код:

[Выделить все]

Option Base 1
Option Explicit
Public xj As Integer, yi As Integer

' *********************************************
' *  СФ БГПА, г.Минск, vNovikov@sf.unibel.by  *
' *       http://helpstud.narod.ru            *
' *********************************************

' Функция двойной линейной интерполяции
Function interpol(xr As Range, yr As Range, xyr As Range, xg As Single, yv As Single) As Variant
    Dim i As Integer, j As Integer, m As Integer, n As Integer  ' Число строк и столбцов
    Dim b1 As Single, b2 As Single, k As Single
    Dim x1 As Single, x2 As Single, y1 As Single, y2 As Single
    Dim xy1 As Single, xy2 As Single, xy3 As Single, xy4 As Single, xy5 As Single, xy6 As Single
    
        
    n = UBound(xr.Value, 2)
    m = UBound(yr.Value, 1)
    If (m = 1 Or n = 1) Then
        interpol = "Ячейки не являются диапазоном"
        Exit Function
    End If
    
    If (m <> UBound(xyr.Value, 1) Or n <> UBound(xyr.Value, 2)) Then
        interpol = "Размеры диапазонов не совпадают"
        Exit Function
    End If
    
    xj = 0: yi = 0
    ' Поиск границ по X
    For j = 1 To n - 1
        b1 = xr(1, j).Value
        b2 = xr(1, j + 1).Value
        If (xg >= Min(b1, b2) And xg < Max(b1, b2)) Then
            xj = j ' Левый верхний индекс
            Exit For
        End If
     Next j
     
    ' По Y
    For i = 1 To m - 1
        b1 = yr(i, 1).Value
        b2 = yr(i + 1, 1).Value
        If (yv >= Min(b1, b2) And yv < Max(b1, b2)) Then
            yi = i
            Exit For
        End If
     Next i
     
     If (xj = 0 Or yi = 0) Then
        interpol = "Значение за пределами диапазона"
        Exit Function
     End If
     
     x1 = xr(1, xj).Value ' Границы
     x2 = xr(1, xj + 1).Value
     y1 = yr(yi, 1).Value
     y2 = yr(yi + 1, 1).Value
     
     xy1 = xyr(yi, xj).Value ' Значения
     xy2 = xyr(yi, xj + 1).Value
     xy3 = xyr(yi + 1, xj).Value
     xy4 = xyr(yi + 1, xj + 1).Value

     ' Горизонтальная интерполяция
     k = (xg - x1) / (x2 - x1)
     xy5 = xy1 + (xy2 - xy1) * k
     xy6 = xy3 + (xy4 - xy3) * k
     
     ' Вертикальная
     interpol = xy5 + (xy6 - xy5) * (yv - y1) / (y2 - y1)
     
'    Interpolation key
'     ! x1  ! xg   ! x2
'  ---------       --------
'  y1 ! xy1 ! xy5  ! xy2
'  yv
'  y2 ! xy3 ! xy6  ! xy4
'
End Function


Function Min(a1 As Single, a2 As Single) As Single
  If a1 <= a2 Then
    Min = a1
  Else
    Min = a2
  End If
End Function

Function Max(a1 As Single, a2 As Single) As Single
  If a1 <= a2 Then
    Max = a2
  Else
    Max = a1
  End If
End Function

[romkeris]

Большое спасибо! Теперь работает.

[Кулик Алексей aka kpblc]

А вот "теперь позвольте пару слов без протокола" - а на фига было косить по иностранца?

[romkeris]

Я и есть иностранец. Просто у меня в доме нет клавы с кирилицои и мой родной язык на латинских буквах. Cледущий раз постараюс писать по рускому.

[Кулик Алексей aka kpblc]

В таком случае прошу прощения.