Option Explicit
'v2
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

Private 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"
                Dim dt As Date
                dt = Now
                Do
                    If .DataLabel.Text <> "" Then Exit Do
                    If dt < Now - TimeSerial(0, 1, 0) Then Exit Do
                    DoEvents
                    Application.Wait Now + TimeSerial(0, 0, 1)
                Loop
                GetDataLabelText = .DataLabel.Text
            End With
        End With
    End With
    wb.Close False
    
    Application.ScreenUpdating = True
End Function

Private Function GetCoefficients2(dataLabelText As String) As Variant
Dim i As Integer
Dim rez() As Variant, txt As Variant
Dim razd As String
txt = Split(dataLabelText, "x")
ReDim rez(LBound(txt) To UBound(txt), 1 To 2)
For i = LBound(txt) To UBound(txt)
    txt(i) = Right(txt(i), IIf(i = LBound(txt), (Len(txt(i)) - 2), (Len(txt(i)) - 1)))
    rez(i, 1) = i
    rez(i, 2) = txt(i)
Next i
GetCoefficients2 = rez
End Function

.DataLabel.NumberFormat = "#.############E+00"

Sub Polynomial()
    Dim rX As Range
    Dim rY As Range
    Dim rOut As Range
    Dim dataLabelText As String
    Dim coefficients As Variant
    
    Set rX = ActiveSheet.Range("B2:B8") ' Данные Х
    Set rY = ActiveSheet.Range("C2:C8") ' Данные Y

    Set rOut = ActiveSheet.Range("E2")
    
    dataLabelText = Извлечение_Полинома(rX, rY)
    coefficients = Извлечение_коэффициентов(dataLabelText)
    rOut.Resize(UBound(coefficients, 1) + 1, UBound(coefficients, 2)) = coefficients
End Sub
 
Private Function Извлечение_коэффициентов(dataLabelText As String) As Variant
Dim i As Integer
Dim rez() As Variant, txt As Variant
txt = Split(dataLabelText, "x")
ReDim rez(LBound(txt) To UBound(txt), 1 To 2)
For i = LBound(txt) To UBound(txt)
    txt(i) = Right(txt(i), IIf(i = LBound(txt), (Len(txt(i)) - 2), (Len(txt(i)) - 1)))
    rez(i, 1) = i: rez(i, 2) = txt(i)
Next i
Извлечение_коэффициентов = rez
End Function

Function Извлечение_Полинома(rX As Range, rY As Range) As String
    Dim MyChart As Chart
    Dim text As String
    Dim dt As Date
    Set MyChart = ActiveSheet.Shapes.AddChart2(, , , , 450, 300).Chart
    With MyChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = rX
        .SeriesCollection(1).Values = rY
        .ChartType = xlXYScatter
        .FullSeriesCollection(1).Trendlines.Add
        With .FullSeriesCollection(1).Trendlines(1)
            .Type = xlPolynomial
            .Order = 6 ' Указываем степень полинома
            DoEvents
            .DisplayEquation = True
            .DataLabel.NumberFormat = "#.####E+00"
            dt = Now
            DoEvents
            DoEvents
            text = .DataLabel.text
        End With
    End With
    Извлечение_Полинома = text
    MyChart.Parent.Delete
End Function

rOut.Resize(UBound(coefficients, 1) + 1, UBound(coefficients, 2)) = coefficients