' Проведение интерполяции с использованием функционала Excel
' На выходе - коэффициенты полинома. Число точек должно быть минимум на одну больше, чем степень полинома.
' Данные берутся из программы
Public Sub Linia_trenda(ByRef Y() As Double, ByRef X() As Double, ByVal PolyStep As Integer, ByRef c() As Double, Optional ByRef r2 As Double)
    Dim stepen As Long
    ' Ввожу проверку не превышения степени массива
    If (UBound(Y) - LBound(Y) - 1) < PolyStep Then
        stepen = UBound(Y) - LBound(Y)
    Else
        stepen = PolyStep
    End If
    ' Объявляю переменные, создаю матрицы под размер данных и степень полинома.
    Dim X1() As Double, y1() As Double
    ReDim X1(LBound(Y) To UBound(Y), 1 To stepen) As Double
    ReDim y1(LBound(Y) To UBound(Y), 1 To 1) As Double
    ReDim c(1 To stepen + 1) As Double
    ' Заполню массив Х в соответствии со степенью уравнения.
    For i = LBound(X) To UBound(X)
        y1(i, 1) = Y(i)
        X1(i, 1) = X(i)
        For N = 2 To stepen
            X1(i, N) = X1(i, 1) ^ N
        Next N
    Next i
    ' Нахожу уравнение.
    Dim Coefs As Variant
        Coefs = WorksheetFunction.LinEst(y1, X1, True, True)
    ' Вытаскиваю коэффициенты полинома.
    For i = 1 To stepen + 1
        c(i) = Coefs(1, i)
    Next i
    ' Вытаскиваю величину достоверности аппроксимации.
    r2 = Coefs(3, 1)
End Sub

' Программа формирования текста уравнения по всем точкам

Public Function Case_uravnenie(xVal As Range, yVal As Range, PolyStep As Long, _
                            Optional NameX As String = "X") As Variant
Dim j As Long
Dim N As Long
Dim k As Long
Dim stepen As Long
Dim xn() As Double    ' заявляем массив X
Dim yn() As Double    ' заявляем массив Y
Dim c() As Double    ' заявляем массив c - коэффециенты уравнения полинома


Case_uravnenie = "" & Chr(10)

Dim Nna4 As Long 'Номер начала диапазона.
Dim Nkon As Long 'Номер конца диапазона.

Nna4 = 1
Nkon = xVal.Count
' Проверяем на соответствие число элементов участка степени полинома
    If (Nkon - Nna4) < PolyStep Then
        stepen = (Nkon - Nna4)
    Else
        stepen = PolyStep
    End If
' Заполняем матрицы участка
    ReDim xn(1 To (Nkon - Nna4 + 1), 1 To stepen)
    ReDim yn(1 To (Nkon - Nna4 + 1), 1 To 1)
    ReDim c(1 To stepen + 1) As Double
    For j = 1 To (Nkon - Nna4 + 1)
        xn(j, 1) = xVal.Rows(j + Nna4 - 1)
        For N = 2 To stepen
            xn(j, N) = xn(j, 1) ^ N
        Next N
        yn(j, 1) = yVal.Rows(j + Nna4 - 1)
    Next j
' Делаем расчёт и вывод.
    For k = 1 To stepen + 1 Step 1
        c(k) = Format(Application.Index(WorksheetFunction.LinEst(yn, xn, True, True), 1, k), "0.####E+")
        
        If c(k) >= 0 And k > 1 Then
            Case_uravnenie = Case_uravnenie & " + " & c(k)
        Else
            Case_uravnenie = Case_uravnenie & c(k)
        End If
        
        If (stepen + 1 - k) > 0 Then
            Case_uravnenie = Case_uravnenie & " * " & NameX & " ^ " & (stepen + 1 - k) & " "
        End If
    Next k
   
Case_uravnenie = Case_uravnenie & Chr(10)
End Function

Public Function polinomEx(xVal As Range, yVal As Range, X As Single, stepen As Integer)
Dim I As Integer
Dim Seria
Seria = Array(1, 2, 3, 4, 5, 6, 7)
If stepen > 7 Then stepen = 7
If xVal.Count < stepen + 1 Then stepen = xVal.Count - 1
polinomEx = 0#
ReDim Preserve Seria(stepen - 1)
For I = 1 To stepen + 1
    polinomEx = polinomEx + _
    (X ^ (stepen + 1 - I)) * _
        Application.Index(WorksheetFunction.LinEst(yVal, _
        IIf(stepen = 1, xVal, Application.Power(xVal, Seria)), _
        True, True), 1, I)
Next I
End Function

Public Function Koef(xVal As Range, yVal As Range, stepen As Integer)
Dim i As Integer
Dim Seria
Dim polinomEx() As Single
Seria = Array(1, 2, 3, 4, 5, 6, 7)
If stepen > 7 Then stepen = 7
If xVal.Count < stepen + 1 Then stepen = xVal.Count - 1
ReDim Preserve Seria(stepen - 1)
ReDim polinomEx(stepen)
For i = 1 To stepen + 1
    polinomEx(i - 1) = Application.Index(WorksheetFunction.LinEst(yVal, _
        IIf(stepen = 1, xVal, Application.Power(xVal, Seria)), _
        True, True), 1, i)
Next i

Koef = polinomEx
End Function

Public Function Koef2(Xish As Variant, Yish As Variant, ByRef stepen As Variant)
Dim c() As Double
Dim X() As Double
Dim Y() As Double
ReDim c(1 To stepen + 1)
Подготовка_данных Xish, Yish, X, Y
Linia_trenda Y, X, stepen, c
Koef2 = c
End Function

' Подпрограмма переопределения значений исходных данных
Function Подготовка_данных(Xvh As Variant, Yvh As Variant, _
                           Xvih() As Double, Yvih() As Double) As Variant
    
    Dim NumYRows As Long, i As Long
    If TypeName(Xvh) = "Range" Then
    ' Если данные взяты с листа эксель
        Xvh = Xvh.Value2
        Yvh = Yvh.Value2
        NumXRows = UBound(Xvh)
        NumYRows = UBound(Yvh)
    
        ReDim Xvih(0 To NumXRows - 1)
        ReDim Yvih(0 To NumXRows - 1)
    
        For i = 1 To NumXRows
            Xvih(i - 1) = Xvh(i, 1)
            Yvih(i - 1) = Yvh(i, 1)
        Next i
    
    Else
    ' Если данные переданы из функции
        NumXRows = UBound(Xvh) + 1
        NumYRows = UBound(Yvh) + 1
        
        ReDim Xvih(0 To NumXRows - 1)
        ReDim Yvih(0 To NumXRows - 1)

        For i = 0 To NumXRows - 1
            Xvih(i) = Xvh(i)
            Yvih(i) = Yvh(i)
        Next i
    End If
End Function

Sub AddTrend()
    ActiveSheet.Shapes.AddChart2(240, xlXYScatterLines).Select
    ActiveChart.SetSourceData Source:=Range( _
        "'Pdm2_2021_11_17_102_(усреднен.)'!$B$4:$C$68")
    ActiveChart.FullSeriesCollection(1).Trendlines.Add
    ActiveChart.FullSeriesCollection(1).Trendlines(1).Select
        
    With ActiveChart.FullSeriesCollection(1).Trendlines(1)
        .Type = xlPolynomial
        .Order = 6
        .DisplayEquation = True
        .DisplayRSquared = False
        .DataLabel.NumberFormat = "0,00000000000000E+00"
        
        'Здесь (например) нужно код тормознуть, иначе дальнейшие действия не имеют смысла....

        Range("Y17").Value = .DataLabel.Text
        MsgBox (.DataLabel.Text)
    End With

        Range("Y17").Value = ActiveChart.FullSeriesCollection(1).Trendlines(1).DataLabel.Text
End Sub

Option Explicit

Sub Polynomial()
    Dim rX As Range
    Dim rY As Range
    Dim rOut As Range
    Set rX = ActiveSheet.Range("B4:B68")
    Set rY = ActiveSheet.Range("C4:C68")
    Set rOut = ActiveSheet.Range("E4")
    
    Dim dataLabelText As String
    dataLabelText = GetDataLabelText(rX, rY)
    Dim coefficients As Variant
    coefficients = GetCoefficients(dataLabelText)
    
    rOut.Resize(UBound(coefficients, 1), UBound(coefficients, 2)) = coefficients
End Sub

Function GetCoefficients(dataLabelText As String) As Variant
    Dim txt As String
    txt = dataLabelText
    txt = Replace(txt, "y = ", "")
    Dim arr As Variant
    arr = Split(txt, " ")
    Dim brr As Variant
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim ii As Integer
    For ii = LBound(arr) To UBound(arr)
        Select Case arr(ii)
        Case "+", "-"
        Case Else
            brr = Split(arr(ii), "x")
            If UBound(brr) = 0 Then
                ReDim brr(0 To 1)
                brr(0) = arr(ii)
                brr(1) = "0"
            Else
                If ii > 0 Then
                    brr(0) = arr(ii - 1) & brr(0)
                End If
                If brr(1) = "" Then brr(1) = "1"
            End If
            dic.Item(brr(1)) = brr(0)
        End Select
    Next
    
    Dim orr As Variant
    If dic.Count = 0 Then
        ReDim orr(1 To 1, 1 To 2)
    Else
        arr = dic.Keys()
        brr = dic.Items()
        Set dic = Nothing
        ReDim orr(1 To UBound(arr) - LBound(arr) + 1, 1 To 2)
        Dim jj As Integer
        For ii = UBound(arr) To LBound(arr) Step -1
            jj = jj + 1
            orr(jj, 1) = arr(ii)
            orr(jj, 2) = CDbl(brr(ii))
        Next
    End If
    GetCoefficients = orr
End Function

Function GetDataLabelText(rX As Range, rY As Range) As String
    If rX.Rows.Count = 1 Then Exit Function
    Dim arX As Variant
    Dim arY As Variant
    arX = rX.Columns(1)
    arY = rY.Cells(1, 1).Resize(UBound(arX, 1), 1)
    
'    Application.ScreenUpdating = False
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With ActiveSheet
        .Cells(1, 1).Resize(UBound(arX, 1), 1) = arX
        .Cells(1, 2).Resize(UBound(arX, 1), 1) = arY
        
        .Shapes.AddChart2(240, xlXYScatter).Select
        With ActiveChart
            .SetSourceData Source:=Cells(1, 1).Resize(UBound(arX, 1), 2) 'Range("Лист1!$A$1:$B$3")
            .FullSeriesCollection(1).Trendlines.Add
            With .FullSeriesCollection(1).Trendlines(1)
                .Type = xlPolynomial
                .Order = 2
                .Type = xlPolynomial
                .Order = 6
                .DisplayEquation = True
                .DataLabel.NumberFormat = "# ##0,00000000000000000000000000000000000000000000000000000000000000000000000000"
                DoEvents
'                Application.Wait Now + TimeSerial(0, 0, 1)
                GetDataLabelText = .DataLabel.Text
            End With
        End With
    End With
    wb.Close False
    
    Application.ScreenUpdating = True
End Function

                If brr(1) = "" Then brr(1) = "1"

.DataLabel.NumberFormat = "0,00000000000000E+00"

GetDataLabelText = .DataLabel.Text