' Макрос создан в Быстрофункции v3.08.xlsm
' Относительное сжатие грунта
' Уравнение касательной к графику в точке Р0
Public Function Относительное_сжатие_kasat(Р As Double ,Р0 As Double)
Относительное_сжатие_kasat = -107.980615199578 * Р0 ^ 6  + 174.284920333581 * Р0 ^ 5 -111.451156391761 * Р0 ^ 4  + 36.4272604523785 * Р0 ^ 3 -6.61049382304943 * Р0 ^ 2  + 0.707825800602692 * Р0  + 5.41782013762093E-05 + _
                             (-647.883691197467 * Р0 ^ 5  + 871.424601667907 * Р0 ^ 4 -445.804625567044 * Р0 ^ 3  + 109.281781357136 * Р0 ^ 2 -13.2209876460989 * Р0  + 0.707825800602692) * (Р - Р0)

End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim uniq As New Collection
Dim i As Long
Dim RezTabl As Worksheet
Set RezTabl = ThisWorkbook.Worksheets("Пример")
Dim arr()
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("выпапдающий")) Is Nothing Then
        ' Первый набор, по первой строке
        For i = 1 To 1000
            On Error Resume Next
            uniq.Add RezTabl.Cells(1, i), CStr(RezTabl.Cells(1, i))
        Next i
        ' Второй набор, по первому стролбцу. Остальное по аналогии
        For i = 1 To 1000
            On Error Resume Next
            uniq.Add RezTabl.Cells(i, 1), CStr(RezTabl.Cells(i, 1))
        Next i
        ReDim arr(1 To uniq.Count)
        For i = 1 To uniq.Count
            arr(i) = uniq(i)
        Next i
    Target.Validation.Delete
    Target.Validation.Add Type:=xlValidateList, Formula1:=Join(arr, ",")
    End If
End Sub