Function ТекущаяДатаВремя(Optional ДиапазонОбновления As Range = Nothing)
    ТекущаяДатаВремя = Now
End Function

Option Explicit
Dim tabSTATE As Range
Dim esl_loess As Range
Dim psl_loess As Range

Function ПРОСАД(nEGE As String, opTYPE%, Optional MODE$ = "VOID", Optional sSetE$ = "VOID", Optional sSetSr$ = "VOID")
' (opTYPE: 0 - оба показателя; 1 - относительная просадочность; 2 - начальное просадочное давление)
  
  Dim dAvrE As Double, dAvrSr As Double 
  Dim soilINDEX As Integer

  Set tabSTATE = Worksheets("Відомість").Range("tb_State")
  Set esl_loess = Range("esl_loess")
  Set psl_loess = Range("psl_loess")

    With tabSTATE
      If sSetE = "VOID" Then dAvrE = AvrIF(.Columns(27), .Columns(1), nEGE, 0) Else dAvrE = CDbl(sSetE)
      If sSetSr = "VOID" Then dAvrSr = AvrIF(.Columns(28), .Columns(1), nEGE, 0) Else dAvrSr = CDbl(sSetSr)
      If MODE = "VOID" Then soilINDEX = AvrIF(.Columns(36), .Columns(1), nEGE, 0) Else soilINDEX = CInt(MODE)
      If dAvrE = 0 And dAvrSr = 0 Then ПРОСАД = "-": Exit Function
    End With

    If soilINDEX = 1 Then

      If opTYPE = 0 Then

        If Fxy(esl_loess, dAvrSr, dAvrE) >= 0.01 Then
          ПРОСАД = Round(Fxy(esl_loess, dAvrSr, dAvrE), 3) & " | " & Round(Fxy(psl_loess, dAvrSr, dAvrE), 2)
        Else
         ПРОСАД = "Н/П"
        End If

      ElseIf opTYPE = 1 Then

        If Fxy(esl_loess, dAvrSr, dAvrE) >= 0# Then
          ПРОСАД = Round(Fxy(esl_loess, dAvrSr, dAvrE), 3)
        Else
          ПРОСАД = "-"
        End If

      ElseIf opTYPE = 2 Then

        If Fxy(esl_loess, dAvrSr, dAvrE) >= 0.01 Then
          ПРОСАД = Round(Fxy(psl_loess, dAvrSr, dAvrE), 3)
        Else
          ПРОСАД = "-"
        End If

      End If

    ElseIf soilINDEX = 0 Then

      ПРОСАД = "-"

    End If

  'ПРОСАД = dAvrE & " | " & dAvrSr & " | " & soilINDEX
End Function

Function Fxy#(Tablo As Range, r#, c#)

  Dim oneROW As Boolean, oneCOL As Boolean
  Dim xVAL#
  Dim ri&, ci&
  Dim x1#, x2#, y1#, y2#
  Dim a10#, a20#, a01#, a02#
  Dim a11#, a12#, a21#, a22#
    
  On Error Resume Next
    
    If Tablo.Rows.Count = 2 Then oneROW = True Else oneROW = False
    If Tablo.Columns.Count = 2 Then oneCOL = True Else oneCOL = False
    
    If oneROW = True And oneCOL = False Then
      ri = 2
      ci = 1 + FindIndex(Range(Tablo.Cells(1, 2), Tablo.Cells(1, Tablo.Columns.Count)), c)
        a01 = Tablo.Cells(1, ci):      a02 = Tablo.Cells(1, ci + 1)
        a11 = Tablo.Cells(ri, ci):     a12 = Tablo.Cells(ri, ci + 1)
          x1 = a01:       x2 = a02
          y1 = a11:       y2 = a12
          xVAL = c
    ElseIf oneROW = False And oneCOL = True Then
      ri = 1 + FindIndex(Range(Tablo.Cells(2, 1), Tablo.Cells(Tablo.Rows.Count, 1)), r)
      ci = 2
        a10 = Tablo.Cells(ri, 1):      a20 = Tablo.Cells(ri + 1, 1)
        a11 = Tablo.Cells(ri, ci)
        a21 = Tablo.Cells(ri + 1, ci)
          x1 = a10:       x2 = a20
          y1 = a11:       y2 = a21
          xVAL = r
    ElseIf oneROW = False And oneCOL = False Then
      ri = 1 + FindIndex(Range(Tablo.Cells(2, 1), Tablo.Cells(Tablo.Rows.Count, 1)), r)
      ci = 1 + FindIndex(Range(Tablo.Cells(1, 2), Tablo.Cells(1, Tablo.Columns.Count)), c)
        a01 = Tablo.Cells(1, ci):      a02 = Tablo.Cells(1, ci + 1)
        a10 = Tablo.Cells(ri, 1):      a20 = Tablo.Cells(ri + 1, 1)
        a11 = Tablo.Cells(ri, ci):     a12 = Tablo.Cells(ri, ci + 1)
        a21 = Tablo.Cells(ri + 1, ci): a22 = Tablo.Cells(ri + 1, ci + 1)
          x1 = a01:       x2 = a02
          y1 = Fx(r, a10, a20, a11, a21)
          y2 = Fx(r, a10, a20, a12, a22)
          xVAL = c
    ElseIf oneROW = True And oneCOL = True Then
      Fxy = 0: Exit Function
    End If
    
    Fxy = Fx(xVAL, x1, x2, y1, y2)
    
End Function

Function Fx(x#, x1#, x2#, y1#, y2#)
    Fx = y1 + (x - x1) * (y2 - y1) / (x2 - x1)
End Function

Function FindIndex&(rg As Range, V)
  Dim IncRg As Boolean, i&
  If rg.Cells(1) < rg.Cells(rg.Cells.Count) Then
    If V < rg.Cells(1) Then FindIndex = 1: Exit Function
    If V > rg.Cells(rg.Cells.Count) Then FindIndex = rg.Cells.Count - 1: Exit Function
    FindIndex = WorksheetFunction.Match(V, rg)
  Else
    If V > rg.Cells(1) Then FindIndex = 1: Exit Function
    If V < rg.Cells(rg.Cells.Count) Then FindIndex = rg.Cells.Count - 1: Exit Function
    FindIndex = WorksheetFunction.Match(V, rg, -1)
  End If
End Function

Function AvrIF(TargetRNG As Range, ConditionRNG As Range, Condition As String, Optional altVAL As String)
  On Error GoTo valERR
    AvrIF = Application.WorksheetFunction.AverageIfs(TargetRNG, ConditionRNG, Condition)
Exit Function
valERR: AvrIF = altVAL
End Function

Sub VALcolect_()
Dim EGE As Range, ValList As Range, ExpVal As Range
Dim valARR, FvalARR, i As Long, j&, k&, q&
Set ExpVal = Range("gen[ИГЕ]")
Set ValList = Range("Физ.свойства[18]")
Set EGE = Range("Физ.свойства[0]")
'1.Формуруем набор рангов объекта_______________________________________
Dim vItem, avArr, li As Long
ReDim avArr(1 To Rows.Count, 1 To 1)
With New Collection
On Error Resume Next
 For Each vItem In EGE.Value
 .Add vItem, CStr(vItem)
 If ERR = 0 Then
  li = li + 1: avArr(li, 1) = vItem
  Else: ERR.Clear
 End If
 Next
End With
    If li Then ExpVal.Resize(li).Value = avArr
'2. Поиск минимального и максимального значения для каждого ранга_______
Erase valARR: Erase FvalARR
ReDim valARR(1 To Rows.Count): ReDim FvalARR(1 To Rows.Count)
On Error Resume Next
For j = 1 To ExpVal.Count
minD = 9999
maxD = -9999
 For i = 1 To EGE.Count
 If EGE.Cells(i, 1) = avArr(j, 1) Then valARR(i) = ValList.Cells(i)
 If valARR(i) <> "" And valARR(i) <> "-" Then
 k = k + 1: FvalARR(k) = valARR(i)
 If minD > FvalARR(k) Then minD = FvalARR(k)
 If maxD < FvalARR(k) Then maxD = FvalARR(k)
 End If: Next i
If minD = 9999 Then GoTo nXt
If maxD = -9999 Then GoTo nXt
'3. Заполнение пустых ячеек по рангу____________________________________
For q = 1 To EGE.Count
If EGE.Cells(q, 1) = avArr(j, 1) Then
 If IsEmpty(ValList.Cells(q, 1)) Then
 ValList.Cells(q, 1).Value = _
 Application.RandBetween(minD * 1000, maxD * 1000) / 1000
End If: End If
Next q
Erase valARR: Erase FvalARR
ReDim valARR(1 To Rows.Count): ReDim FvalARR(1 To Rows.Count)
nXt: Next j
End Sub

Function ValByRank(RankList As Range, ValList As Range, RankVal As Range)
Dim valARR, i As Long
Dim FvalARR, j&, k&
ReDim valARR(1 To Rows.Count, 1 To 1)
On Error Resume Next
  For i = 1 To RankList.Count
    If RankList.Cells(i, 1) = RankVal Then
      valARR(i, 1) = ValList.Cells(i, 1)
    End If
  Next i
ReDim FvalARR(1 To UBound(valARR), 1 To 1)
  For j = 1 To UBound(valARR)
    If valARR(j, 1) <> "" Then
      k = k + 1
        FvalARR(k, 1) = valARR(j, 1)
    End If
  Next j
    ValByRank = FvalARR
End Function

Function ПОЛИНОМ_ЗНАЧ(WorkRange As Range, CondRange As Range, CondVAL As Double)
  With Application
    LinEstVAL = .LinEst(WorkRange, .Power(CondRange, Array(1, 2, 3, 4, 5, 6)))
      a_1 = .Index(LinEstVAL, 1) * CondVAL ^ 6
      a_2 = .Index(LinEstVAL, 1, 2) * CondVAL ^ 5
      a_3 = .Index(LinEstVAL, 1, 3) * CondVAL ^ 4
      a_4 = .Index(LinEstVAL, 1, 4) * CondVAL ^ 3
      a_5 = .Index(LinEstVAL, 1, 5) * CondVAL ^ 2
      a_6 = .Index(LinEstVAL, 1, 6) * CondVAL ^ 1
      a_7 = .Index(LinEstVAL, 1, 7)
  End With
ПОЛИНОМ_ЗНАЧ = a_1 + a_2 + a_3 + a_4 + a_5 + a_6 + a_7
End Function

Function Fxy#(Tablo As Range, r#, c#)
  Dim ri&, ci&
  ri = 1 + FindIndex(Range(Tablo.Cells(2, 1), Tablo.Cells(Tablo.Rows.Count, 1)), r)
  ci = 1 + FindIndex(Range(Tablo.Cells(1, 2), Tablo.Cells(1, Tablo.Columns.Count)), c)
  Fxy = Fx(c, Tablo.Cells(1, ci), Tablo.Cells(1, ci + 1), _
  Fx(r, Tablo.Cells(ri, 1), Tablo.Cells(ri + 1, 1), Tablo.Cells(ri, ci), Tablo.Cells(ri + 1, ci)), _
  Fx(r, Tablo.Cells(ri, 1), Tablo.Cells(ri + 1, 1), Tablo.Cells(ri, ci + 1), Tablo.Cells(ri + 1, ci + 1)))
End Function
 
 
Function Fx(x#, x1#, x2#, y1#, y2#)
  Fx = y1 + (x - x1) * (y2 - y1) / (x2 - x1)
End Function
 
 
Private Function FindIndex&(rg As Range, V)
  Dim IncRg As Boolean, i&
  If rg.Cells(1) < rg.Cells(rg.Cells.Count) Then
    If V < rg.Cells(1) Then FindIndex = 1: Exit Function
    If V > rg.Cells(rg.Cells.Count) Then FindIndex = rg.Cells.Count - 1: Exit Function
    FindIndex = WorksheetFunction.Match(V, rg)
  Else
    If V > rg.Cells(1) Then FindIndex = 1: Exit Function
    If V < rg.Cells(rg.Cells.Count) Then FindIndex = rg.Cells.Count - 1: Exit Function
    FindIndex = WorksheetFunction.Match(V, rg, -1)
  End If End Function

'===== СТРОКИ
rStep = --Format$(arrTbl(3, 1) - arrTbl(2, 1), "0.0000"): If valRow < arrTbl(2, 1) Or valRow > arrTbl(UBound(arrTbl, 1), 1) Then GoTo ex
rMin = PRV_RoundAccSokol(valRow, rStep): If rMin + rStep > arrTbl(UBound(arrTbl, 1), 1) Then OneRow = True

'===== СТОЛБЦЫ
cStep = --Format$(arrTbl(1, 3) - arrTbl(1, 2), "0.0000"): If valCol < arrTbl(1, 2) Or valCol > arrTbl(1, UBound(arrTbl, 2)) Then GoTo ex
cMin = PRV_RoundAccSokol(valCol, cStep): If cMin + cStep > arrTbl(1, UBound(arrTbl, 2)) Then OneCol = True
 
'===== 4 значения
iCol = PRV_MatchByStep(cMin, arrTbl(1, 2), cStep) + 1: iRow = PRV_MatchByStep(rMin, arrTbl(2, 1), rStep) + 1: ReDim arrX(0 To 3): arrX(0) = arrTbl(iRow, iCol)
    If OneRow Then
        If OneCol Then ReDim Preserve arrX(0 To 0) Else ReDim Preserve arrX(0 To 1): arrX(1) = arrTbl(iRow, iCol + 1)
    Else
        arrX(1) = arrTbl(iRow + 1, iCol): If OneCol Then ReDim Preserve arrX(0 To 1) Else arrX(2) = arrTbl(iRow, iCol + 1): arrX(3) = arrTbl(iRow + 1, iCol + 1)
    End If

Option Explicit
'====================================================================================================
Function FILE_GetValuesFromCrossTable(rngTbl As Range, valRow#, valCol#) As String
Dim arrTbl, iRow&, iCol&
Dim cStep#, cMin#, OneCol As Boolean
Dim rStep#, rMin#, OneRow As Boolean
Dim x, arrX()
Dim i, j
If rngTbl Is Nothing Or valRow = 0 Or valCol = 0 Then Exit Function
If rngTbl.Rows.Count < 3 Or rngTbl.Columns.Count < 3 Then Exit Function Else arrTbl = rngTbl.Value2
 
'===== СТРОКИ
rStep = --Format$(arrTbl(3, 1) - arrTbl(2, 1), "0.0000"): If valRow < arrTbl(2, 1) Or valRow > arrTbl(UBound(arrTbl, 1), 1) Then GoTo ex
rMin = PRV_RoundAccSokol(valRow, rStep): If rMin + rStep > arrTbl(UBound(arrTbl, 1), 1) Then OneRow = True
 
'===== СТОЛБЦЫ
cStep = --Format$(arrTbl(1, 3) - arrTbl(1, 2), "0.0000"): If valCol < arrTbl(1, 2) Or valCol > arrTbl(1, UBound(arrTbl, 2)) Then GoTo ex
cMin = PRV_RoundAccSokol(valCol, cStep): If cMin + cStep > arrTbl(1, UBound(arrTbl, 2)) Then OneCol = True
 
'===== 4 значения
iCol = PRV_MatchByStep(cMin, arrTbl(1, 2), cStep) + 1: iRow = PRV_MatchByStep(rMin, arrTbl(2, 1), rStep) + 1: ReDim arrX(0 To 3): arrX(0) = arrTbl(iRow, iCol)
    If OneRow Then
        If OneCol Then ReDim Preserve arrX(0 To 0) Else ReDim Preserve arrX(0 To 1): arrX(1) = arrTbl(iRow, iCol + 1)
    Else
        arrX(1) = arrTbl(iRow + 1, iCol): If OneCol Then ReDim Preserve arrX(0 To 1) Else arrX(2) = arrTbl(iRow, iCol + 1): arrX(3) = arrTbl(iRow + 1, iCol + 1)
    End If
'===== Фильтрация arrX при valRow и valCol кратным Step (добавлено)
If valRow = rMin Or valCol = cMin Then arrX(3) = 0 Else
If valRow = rMin Then arrX(1) = 0 Else
If valCol = cMin Then arrX(2) = 0
'FILE_GetValuesFromCrossTable = iRow & " | " & iCol
iRow = -1
    For Each x In arrX
        'If Len(x) Then iRow = iRow + 1: arrX(iRow) = x                                         'пустые ячейки приводят к ошибке
        iRow = iRow + 1: If Len(x) Then arrX(iRow) = x Else arrX(iRow) = 0                      '(скопировано) заменяем в цикле пустые значения на нули
    Next x
If iRow = -1 Then Exit Function Else ReDim Preserve arrX(0 To iRow):
    On Error GoTo ex
    i = arrX(0) + ((arrX(2) - arrX(0)) / cStep) * (valCol - cMin)                               '(добавлено) интерполяция по valCol для iRow
    j = arrX(1) + ((arrX(3) - arrX(1)) / cStep) * (valCol - cMin)                               '(добавлено) интерполяция по valCol для iRow + 1
FILE_GetValuesFromCrossTable = i + ((j - i) / rStep) * (valRow - rMin)                          '(добавлено) интерполяция по valRow
'FILE_GetValuesFromCrossTable = Application.Round(i + ((j - i) / rStep) * (valRow - rMin), 0)   '[опционально] округление до целого числа
'FILE_GetValuesFromCrossTable = FILE_GetValuesFromCrossTable & vbLf & Join(arrX, " - ")
ex: End Function
'====================================================================================================
Private Function PRV_RoundAccSokol(valNum#, Accuracy#) As Double
If (1000000 * valNum) Mod (1000000 * Accuracy) = 0 Then PRV_RoundAccSokol = valNum Else PRV_RoundAccSokol = Int(valNum / Accuracy) * Accuracy
End Function
'====================================================================================================
Private Function PRV_MatchByStep(valFind#, ByVal valFirst#, Step#) As Long
PRV_MatchByStep = ((valFind - valFirst) / Step) + 1
End Function
'====================================================================================================