Public Function parsing_1(txt As String, x As String, kks As String) As String
Dim Mas(1 To 10000) As String
Dim i As Long, k As Long, k0 As Long, m As Long
Dim rez As String
txt = Replace(txt, " ", "")
txt = Replace(txt, ",", ".")
txt = Replace(txt, "+-", "-")
For i = 1 To Len(txt)
    Mas(i) = Mid(txt, i, 1)
Next i
For i = 1 To UBound(Mas)
    If Mas(i) = "^" Then
        Mas(i) = ","
        For k = UBound(Mas) - 2 To i + 1 Step -1
            Mas(k + 2) = Mas(k + 1)
        Next k
        Mas(i + 2) = ")"
        ' Обработка степени числа, НЕ ВЫРАЖЕНИЯ
        If Mas(i - 1) <> ")" Then
            For k = i To 1 Step -1
                If Mas(k) = "+" Or _
                   Mas(k) = "-" Or _
                   Mas(k) = "*" Or _
                   Mas(k) = "/" Or _
                   Mas(k) = "(" Then
                    k0 = k
                    Exit For
                End If
            Next k
            For k = UBound(Mas) - 4 To k0 + 1 Step -1
                Mas(k + 4) = Mas(k)
            Next k
            Mas(k0 + 1) = "p"
            Mas(k0 + 2) = "o"
            Mas(k0 + 3) = "w"
            Mas(k0 + 4) = "("
        End If
        ' Обработка степени ВЫРАЖЕНИЯ
        If Mas(i - 1) = ")" Then
            For k = i - 1 To 1 Step -1
                If Mas(k) = ")" Then
                    m = m + 1
                End If
                If Mas(k) = "(" Then
                    m = m - 1
                End If
                If m = 0 Then
                    k0 = k
                    Exit For
                End If
            Next k
            For k = UBound(Mas) - 4 To k0 Step -1
                Mas(k + 4) = Mas(k)
            Next k
            Mas(k0 + 0) = "p"
            Mas(k0 + 1) = "o"
            Mas(k0 + 2) = "w"
            Mas(k0 + 3) = "("
        End If
    End If
Next i
For j = 1 To UBound(Mas)
    rez = rez & Mas(j)
Next j
parsing_1 = Replace(rez, x, kks)
End Function

Sub Averageifs_Function1()
    tmp = "<" & CDbl(Range("A7"))
    [D2] = WorksheetFunction.AverageIfs(Range("B2:B12"), _
                                        Range("A2:A12"), tmp)
End Sub

Public Function test(a As Double, b As Double, name As String) As String
    test = vbLf & "Public Function " & name & "( x as double, y as double) as variant" & vbLf
    If a > b Then
        test = test & name & " =x *" & a & "+" & b & "* y" & vbLf
    Else
        test = test & name & " = ""нет решения""" & vbLf
    End If
    test = test & "End Function" & vbLf
End Function

=ЕСЛИОШИБКА(ПРОСМОТР(2;1/(Таблица1[Дата]<I5)/(Таблица1[Буква]=I6);Таблица1[Цифра]);"нет данных")

Определение коэффициентов линейного уравнения
y=ax+b   
b=   1.397235    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7;1);1;2)
a=   -0.027554    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7;1);1;1)

Определение коэффициентов квадратичного уравнения
y=ax2+bx+c   
c=   1.662612    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7^{1;2};);1;3)
b=   -0.071047    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7^{1;2};);1;2)
a=   0.000849    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7^{1;2};);1;1)

Определение коэффициентов кубического уравнения
y=ax3+bx²+cx+d   
d=   1.872900    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7^{1;2;3};);1;4)
c=   -0.132192    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7^{1;2;3};);1;3)
b=   0.004066    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7^{1;2;3};);1;2)
a=   -0.000042    =ИНДЕКС(ЛИНЕЙН($B$2:$B$7;$A$2:$A$7^{1;2;3};);1;1)

Коэф-ты уравнения 
y = а · Х ^ m      
m =   -0.6320    =ИНДЕКС(ЛИНЕЙН(E3:E8;D3:D8);1)
A  =   1.1596    =ИНДЕКС(ЛИНЕЙН(E3:E8;D3:D8);2)
a  =   3.1888    =EXP(H4)

Коэф-ты уравнения 
y = а · ln(x) + b      
a =    -0.4676    =ИНДЕКС(ЛИНЕЙН(B3:B8;D3:D8);1)
b =    2.0017    =ИНДЕКС(ЛИНЕЙН(B3:B8;D3:D8);2)

Public Sub udal_Zap()
    [a1] = Application.Run("bighouse.xlam!h_pt", 2, 320)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C1")) Is Nothing Then
    Range("C2").Formula = "=C1+1"
End If

If Not Intersect(Target, Range("C2")) Is Nothing Then
    Range("C1").Formula = "=C2+2"
End If
End Sub

 ' Задаю имя последнему объекту
ActiveSheet.Shapes(ActiveSheet.ChartObjects.Count).Name = "Временная"
....
' В конце удаляю диаграмму с этим именем
ActiveSheet.Shapes("Временная").Delete

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:B6")
    Set rY = ActiveSheet.Range("C2:C6")
    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
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
Извлечение_коэффициентов = 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
    
    ActiveSheet.Shapes(ActiveSheet.ChartObjects.Count).Name = "Временная"

    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 = 2 ' Указываем степень полинома
            .DisplayEquation = True
            .DataLabel.NumberFormat = "#.############E+00"
            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
            text = .DataLabel.text
        End With
    End With
    Извлечение_Полинома = text
    
    ActiveSheet.Shapes("Временная").Delete
    
End Function

Sub Создать_диаграмму_3()
    Dim MyChart As Chart
    Dim i As Integer, Xmin As Single, dX As Single, Xmax As Single, Ymin As Single, Ymax As Single, dY As Single
    Dim X() As Single
    Dim Y1() As Single
    Dim Y2() As Single
    Xmin = 0: Xmax = 300: dX = 20 ' Сие больше нужно для осей и оформления
    Ymin = 0: Ymax = 160: dY = 20
    
    ReDim X(0 To Xmax - Xmin): ReDim Y1(0 To Xmax - Xmin): ReDim Y2(0 To Xmax - Xmin)
    
    For i = 0 To Xmax - Xmin Step 1
        X(i) = Xmin + i
        Y1(i) = X(i) - 20
        Y2(i) = X(i) + 20
    Next i
    
    Set MyChart = ActiveSheet.Shapes.AddChart2.Chart
    ' Создаём первый график
    With MyChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = X
        .SeriesCollection(1).Values = Y1
        .ChartType = xlXYScatterSmoothNoMarkers
    End With
    ' Создаём 2 график
    With MyChart
        .SeriesCollection.NewSeries
        .SeriesCollection(2).XValues = X
        .SeriesCollection(2).Values = Y2
        .ChartType = xlXYScatterSmoothNoMarkers
    End With
End Sub

Sub Создать_диаграмму_4()
    Dim MyChart As Chart
    Dim i As Integer, Xmin As Single, dX As Single, Xmax As Single, Ymin As Single, Ymax As Single, dY As Single
    Dim X() As Single
    Dim Y() As Single
    Dim Yp() As Single
    Xmin = 0: Xmax = 300: dX = 20 ' Сие больше нужно для осей и оформления
    Ymin = 0: Ymax = 160: dY = 20
    
    ReDim X(0 To Xmax - Xmin): ReDim Y(0 To Xmax - Xmin, 1 To 2): ReDim Yp(0 To Xmax - Xmin)
    
    For i = 0 To Xmax - Xmin Step 1
        X(i) = Xmin + i
        Y(i, 1) = X(i) - 20
        Y(i, 2) = X(i) + 20
    Next i
    
    Set MyChart = ActiveSheet.Shapes.AddChart2.Chart

    For i = 1 To 2
            For j = 0 To Xmax - Xmin Step 1 ' Можно ли избавиться от этого?
                Yp(j) = Y(j, i)
            Next j
        With MyChart
            .SeriesCollection.NewSeries
            .SeriesCollection(i).XValues = X
            .SeriesCollection(i).Values = Yp
            .ChartType = xlXYScatterSmoothNoMarkers
        End With
    Next i

End Sub

Sub Макрос9()
    ActiveSheet.ChartObjects("Диаграмма 11").Activate
    With ActiveSheet.Shapes("Диаграмма 11").TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
End Sub

Sub Макрос11()
'
' Макрос11 Макрос
'

'
    ActiveSheet.ChartObjects("Диаграмма 11").Activate
    With ActiveSheet.Shapes("Диаграмма 11").TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Solid
    End With
End Sub

 {=crspline1da(A2:A11;B2:B11;D2:D47)}

Sub Nadstr()
' Переводим последний символ в надстрочное положение
With ActiveCell.Characters(Start:=Len(Selection), Length:=1)
.Font.Superscript = True
End With
End Sub

Public Function steamSPT(T As Single, PR As Single) As Single
Dim YR, A4, A5, S0 As Single
Dim BP(1 to 4), CP(1 to 3), KP(1 to 5)
BP = Array(0.0003237, 0.00025, -0.0011354, -0.0004381)
CP = Array(0.0000056084, -0.0000025993, -0.000000012604)
KP = Array(2127.87, 1482.85, 379.026, 46.174, 10816.1)

YR = (T + 273.15) / 1000#
A4 = -BP(2) + 2 * BP(3) / (YR ^ 3) + 2 * BP(4) / ((YR - 0.21) ^ 3)
A5 = 8 * CP(2) / (YR ^ 9) + 14 * CP(3) / (YR ^ 15)
S0 = (KP(2) * Log(YR) + 2 * KP(3) * YR - KP(4) / YR + KP(5)) / 1000
steamSPT = S0 + A4 * PR + A5 * PR * PR / 2 - 0.46151 * Log(1000 * PR)

End Function

Public Function steamSPT(T As Single, PR As Single) As Single
Dim YR, A4, A5, S0 As Single

Dim BP(), CP(), KP()
BP = Array(0, 0.0003237, 0.00025, -0.0011354, -0.0004381)
CP = Array(0, 0.0000056084, -0.0000025993, -0.000000012604)
KP = Array(0, 2127.87, 1482.85, 379.026, 46.174, 10816.1)

YR = (T + 273.15) / 1000#
A4 = -BP(2) + 2 * BP(3) / (YR ^ 3) + 2 * BP(4) / ((YR - 0.21) ^ 3)
A5 = 8 * CP(2) / (YR ^ 9) + 14 * CP(3) / (YR ^ 15)
S0 = (KP(2) * Log(YR) + 2 * KP(3) * YR - KP(4) / YR + KP(5)) / 1000
steamSPT = S0 + A4 * PR + A5 * PR * PR / 2 - 0.46151 * Log(1000 * PR)

End Function

=ИНДЕКС(ЛИНЕЙН($B$2:$B$37;$A$2:$A$37^{1;2;3});1) 

Public Function Popravka3(parametr As Single, krit As Single) As Single

' Задаю массивы из четырёх элементов. Т.е. у нас четыре графика
Dim kriv(0 To 3) As Currency
Dim kritgraf(0 To 3) As Currency

' Коэффициенты полинома
Dim koefA As Currency
Dim koefB As Currency
Dim koefC As Currency
Dim koefD As Currency

' ввести уравнения кривых и критерии относящиеся к кривым. Уравнения в качестве примера.
kriv(0) = 2 * parametr + 3
kritgraf(0) = 100
kriv(1) = 3 * parametr + 3
kritgraf(1) = 100
kriv(2) = 4 * parametr + 3
kritgraf(2) = 100
kriv(3) = 5 * parametr + 3
kritgraf(3) = 100

' Собственно расчёт. Интерполяция кубическим сплайном (по трём кривым).
 koefA = INDEX(LINEST(kriv,kritgraf^{1,2,3}),1,1)
 koefB = INDEX(LINEST(kriv,kritgraf^{1,2,3}),1,2)
 koefC= INDEX(LINEST(kriv,kritgraf^{1,2,3}),1,3)
 koefD= INDEX(LINEST(kriv,kritgraf^{1,2,3}),1,4)
  
 Popravka3 = koefA * krit * krit * krit + koefB * krit* krit  + koefC* krit + koefD 
End Function