Ну вот, 10 лет в школе, 6 в институте, 4 в аспирантуре, более 15 лет полевой практики, начальник отдела паротурбинных установок центрального ремонтно–механического завода, и вот свершилось - доверили лопату, и выпустили на субботник :). Вообще полезное действие - позитивно поработали.

И да, с завтрашнего дня в отпуске. Планов - громадьё. Починить ОДА-102СВР, таки освоить "PowerQuery в Excel и PowerBi: сбор, объединение и преобразование данных" Г.Равив. А то купил и никак руки не дойдут сесть за неё. Ну и парочку постов на Пикабу, раз обещал.

"Позабыты хлопоты, остановлен бег, Вкалывают роботы, счастлив человек!"(с)ПЭ

В этом посте я хотел бы показать, что ничего сложного в создании макроса, который бы выполнял рутинную работу по созданию макросов нет.

Всё базируется на трёх китах:

1. Унификация.

2. Результатом действия макроса может являться текст;

3. В текстовых переменных можно использовать спец символы:

3.1. Знак возврата каретки. vbCr она же символ Chr(13);

3.2. Знак перевода строки. vbLf она же символ Chr(10);

3.3. Символ объёдинения &.

Ну а теперь пройдём все шаги вместе.

В прошлом посте я говорил про макрос расчёта на основании построения тренда.

====

' Апроксимация полиномом для всего массива исходных данных

' В подпрограмму передаются все заданные точки и апроксимация ведётся по всем точкам!

' Данные из листа Excel

Public Function polinomEx_all(xVal As Range, yVal As Range, x As Single, Optional stepen As Long = 2) As Variant

Dim i As Integer

' Проверка требования "число элементов массива на 1 больше чем степень полинома"

If xVal.Count < stepen + 1 Then

stepen = xVal.Count - 1

End If

polinomEx_all = 0#

Select Case stepen

Case 1 ' Уравнение а·х+b

For i = 1 To stepen + 1

polinomEx_all = polinomEx_all + (x ^ (stepen + 1 - i)) * Application.Index(WorksheetFunction.LinEst(yVal, xVal, True, True), 1, i)

Next i

Case 2 ' Уравнение а·х^2+b·x+c

For i = 1 To stepen + 1

polinomEx_all = polinomEx_all + _

(x ^ (stepen + 1 - i)) * Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2)), True, True), 1, i)

Next i

Case 3 ' Уравнение а·х^3+b·x^2+c·x+d

For i = 1 To stepen + 1

polinomEx_all = polinomEx_all + _

(x ^ (stepen + 1 - i)) * Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3)), True, True), 1, i)

Next i

Case 4 ' Уравнение а·х^4+b·x^3+c·x^2+d·x+e

For i = 1 To stepen + 1

polinomEx_all = polinomEx_all + _

(x ^ (stepen + 1 - i)) * Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4)), True, True), 1, i)

Next i

Case 5 ' Уравнение а·х^5+b·x^4+c·x^3+d·x^2+e·x+f

For i = 1 To stepen + 1

polinomEx_all = polinomEx_all + _

(x ^ (stepen + 1 - i)) * Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4, 5)), True, True), 1, i)

Next i

Case 6 ' Уравнение а·х^6+b·x^5+c·x^4+d·x^3+e·x^2+f·x+g

For i = 1 To stepen + 1

polinomEx_all = polinomEx_all + _

(x ^ (stepen + 1 - i)) * Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4, 5, 6)), True, True), 1, i)

Next i

Case 7 ' Уравнение а·х^7+b·x^6+c·x^5+d·x^4+e·x^3+f·x^2+g·x+h

For i = 1 To stepen + 1

polinomEx_all = polinomEx_all + _

(x ^ (stepen + 1 - i)) * Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4, 5, 6, 7)), True, True), 1, i)

Next i

Case Else

End Select

End Function

====

Как видно - ничего сложного в этом макросе нет. В соответствии с заявленной степенью полинома происходит перемножение заданного Х в соответствующей степени на соответствующий коэффициент полинома. Коэф-ты вычисляются точно так же как вычислялись на листе экселя.

Т.е.

WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4)), True, True)

полностью совпадает с

ЛИНЕЙН(Y; X{1;2;3;4}; True; True)

Ну а теперь просто заменим расчёт на составление текстовой переменной

=====

' Апроксимация полиномом для всего массива исходных данных

' В подпрограмму передаются все заданные точки и апроксимация ведётся по всем точкам!

' Данные из листа Excel

' Результат работы программы - текст (уравнение полинома)

Public Function polinomExStr(ByVal xVal As Range, ByVal yVal As Range, Optional stepen As Long = 2) As Variant

' Проверка требования "число элементов массива на 1 больше чем степень полинома"

Dim i As Integer

If xVal.Count < stepen + 1 Then

stepen = xVal.Count - 1

End If

polinomExStr = ""

Select Case stepen

Case 1 ' Уравнение а·x+c

For i = 1 To 2

polinomExStr = polinomExStr & " + X ^ " & (2 - i) & " * " _

& Format(Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1)), True, True), 1, i), "0.###E+")

Next i

Case 2 ' Уравнение а·х^2+b·x+c

For i = 1 To 3

polinomExStr = polinomExStr & " + X ^ " & (3 - i) & " * " _

& Format(Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2)), True, True), 1, i), "0.###E+")

Next i

Case 3 ' Уравнение а·х^3+b·x^2+c·x+d

For i = 1 To 4

polinomExStr = polinomExStr & " + X ^ " & (4 - i) & " * " _

& Format(Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3)), True, True), 1, i), "0.###E+")

Next i

Case 4 ' Уравнение а·х^4+b·x^3+c·x^2+d·x+e

For i = 1 To 5

polinomExStr = polinomExStr & " + X ^ " & (5 - i) & " * " _

& Format(Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4)), True, True), 1, i), "0.###E+")

Next i

Case 5 ' Уравнение а·х^5+b·x^4+c·x^3+d·x^2+e·x+f

For i = 1 To 6

polinomExStr = polinomExStr & " + X ^ " & (6 - i) & " * " _

& Format(Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4, 5)), True, True), 1, i), "0.###E+")

Next i

Case 6 ' Уравнение а·х^6+b·x^5+c·x^4+d·x^3+e·x^2+f·x+g

For i = 1 To 7

polinomExStr = polinomExStr & " + X ^ " & (7 - i) & " * " _

& Format(Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4, 5, 6)), True, True), 1, i), "0.###E+")

Next i

Case 7 ' Уравнение а·х^7+b·x^6+c·x^5+d·x^4+e·x^3+f·x^2+g·x+h

For i = 1 To 8

polinomExStr = polinomExStr & " + X ^ " & (8 - i) & " * " _

& Format(Application.Index(WorksheetFunction.LinEst(yVal, Application.Power(xVal, Array(1, 2, 3, 4, 5, 6, 7)), True, True), 1, i), "0.###E+")

Next i

Case Else

End Select

End Function

=====

Ну или немного в другом виде с учётом ряда особенностей и модификаций

=====

' Программа формирования текста макроса для функции одного уравнения

Public Function fun_macros_Y(xVal As Range, yVal As Range, PolyStep As Long, _

Optional Name_f As String = "Nomogramma", _

Optional Opisanie As String = " Уравнение ", _

Optional NameX As String = "Xisk") 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 - коэффециенты уравнения полинома

fun_macros_Y = "" & Chr(10) & "' " & Opisanie & Chr(10)

fun_macros_Y = fun_macros_Y & "Public Function " & Name_f & "(ByRef " & NameX & " As Single) As Variant" & 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

' Делаем расчёт и вывод.

fun_macros_Y = fun_macros_Y & Name_f & " = "

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

fun_macros_Y = fun_macros_Y & " + " & c(k)

Else

fun_macros_Y = fun_macros_Y & c(k)

End If

If (stepen + 1 - k) > 0 Then

fun_macros_Y = fun_macros_Y & " * " & NameX & " ^ " & (stepen + 1 - k) & " "

End If

Next k

fun_macros_Y = fun_macros_Y & Chr(10) & "End Function" & Chr(10)

End Function

=====

Макрос ждёт в качестве вводных данных:

xVal - столбец известных Х

yVal - столбец известных Y

PolyStep - желаемую степень уравнения. Если точек будет меньше чем требуется для степени - на уменьшится

Name_f - название получаемого макроса. Опционально. Если не задать будет Nomogramma

Opisanie - описание получаемого макроса. Опционально. Если не задать будет Уравнение

NameX - название/имя аргумента. Опционально. Если не задать будет Xisk

Вызов макроса:

=ПОДСТАВИТЬ(fun_macros_Y(X; Y; 3; "fun_пример"; "Пример создания макроса"; "Go");",";".")

=ПОДСТАВИТЬ( ;",";".") требуется для замены запятых на точки. Иначе будет казус - VBA в качестве разделителя целой и дробной части использует точку, а в текстом виде (по крайней мере в рус.экселе) разделитель запятая.

Обратите внимание, что

"fun_пример"; "Пример создания макроса"; "Go" - текстовые, т.е. заключаются в кавычки

"fun_пример";  "Go" - должны соответствовать требованиям к переменным. Т.е. не должны содержать пробелов, не должны совпадать с имеющимися переменными или названиями ячеек/диапазонов.

Результатом выполнения макроса будет (поставил 3-ю степень чтобы результат влез в окно поста):

"

' Пример создания простого макроса

Public Function fun_Wтф(ByRef Go As Single) As Variant

fun_Wтф = 0.00000056401 * Go ^ 3 -0.001952 * Go ^ 2 + 1.3842 * Go ^ 1 + 25.341

End Function

"

Останется скопировать данный текст в модуль VBA и удалить двойные кавычки в начале и конце текстовки.

Если есть желание повысить количество знаков коэффициентов - правим формат "0.####E+"

Для ускорения работы у меня собраны листы/шаблоны позволяющие не лезть в заполнение вызова макросов.

Вызов макроса для данного случая у меня выглядит так (в Е9):

=ПОДСТАВИТЬ(fun_macros_Y(B3:ДВССЫЛ("B"&E4);C3:ДВССЫЛ("C"&E4);M7;E7;G5;G7);",";".")

Как заполнены дополнительные столбцы А, D и ячейки Е4 и т.д. видно на скрине.

Столбец А - контроль верности снятия данных (по возрастанию Х).

Столбец D - подсчёт снятых точек.

В итоге выполнение/изготовление макроса для меня сводится в вставке исходных данных начиная с ячейки В3, и затем жёлтых полей ввода описания, ввода названия новой функции и аргумента, выбора степени. Т.е. занимает не более минуты.

Для наблюдательных - присутствующие в макросе Dim Nna4 As Long 'Номер начала диапазона.

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

намекают на то, что после небольшой модификации данный макрос можно использовать для более сложных диаграмм. Но об этом позднее... Думаю что через неделю в лучшем случае.

Для продвинутых - да, можно обойтись без доп.столбцов А и D, да и E4 лишнее. И то и другое можно реализовать в макросе, но...но данный лист был так сформирован на основании удобства для меня - могу оперативно проверить правильность и полноту вставки исходных данных, отсутствие сбоев "снятия" точек с картинки при массовой оцифровке. И вообще - "работает? Стабильно? Без сбоев? Не трожь!" (с)Анекдот. Вам ничто не мешает сделать иначе.

=========

dixi

Краткий план:

Теория вкратце [ Часть 1. ]

Забираем данные с листа. [ Часть 2. ]

Апроксимация простых графиков полиномом средствами Excel [ Часть 3.]

Макрос по созданию макросов апроксимации простых графиков полиномом [ Часть 4.] Этот пост

Апроксимация графиков двух аргументов полиномом [ Часть 5.]

Кусочная интерполяция простых графиков [ Часть 6.]

Итак, мы имеем набор точек XY и нам требуется определить значение между заданными (опорными) точками. Начнём с самого простого варианта - набор точек позволяет найти уравнение полиномиального вида, которое с достаточной нам точностью описывает поведение функции с учётом имеющихся точек. Это будет в 90% апроксимация т.к. помним про погрешности связанные со снятием точек. Т.е. значения полученные по данной функции будут отличаться от заданных изначально. Кроме вариантов при степени полинома на 1 меньше количества точек (например полином 5-й степени, а известных точек 6-ть).

Стоит учитывать, что описанный ниже способ подходит только в ограниченном количестве случаев:

- требует заказчик;

- зависимость явно полиномиальная.

Итак, в общем случае всё сводится к пяти шагам:

1. По имеющимся данным построить точечный график.

2. По построенным точкам выполнить построение линии тренда.

3. Подобрать степень полиномиальной зависимости таким образом, чтобы внешний вид (прохождение около/через заданные точки) соответствовал изначальному графику (тот что был на картинке). Проверить, возможно полином не лучший вариант.

4. Отобразить уравнение линии тренда на диаграмме и, если зависимость полиномиальная, становить формат чисел "Экспоненциальный" Число знаков - не менее 3х знаков.

5. Скопировать полученное уравнение и использовать в дальнейшем.

Есть ли способы без построения? Естественно есть (о них чуть подальше), но не видя как расположена линия тренда можно нарваться на неприятности.

Ещё одно заблуждение - "чем больше степень полинома, тем точнее". К сожалению, если по оси Х значения в десятках тысяч, а по оси Y в единицах фактически не реально найти полином выше 5-й степени. Точнее определить с достаточной достоверностью его коэффициенты (просто не хватает 15-ти знаков).

Определение коэффициентов полинома.

Как видно на скриншоте выше извлечение коэффициентов полинома происходит совсем не сложно.

=ИНДЕКС(ЛИНЕЙН(F4:F13;E4:E13^{1;2;3;4;5;6});1;7)

где {1;2;3;4;5;6} - степень полинома, 7 - порядковый номер коэффициента.

И об этом написано в многих местах. Но вот то что не написано - извлечённые таким способом иногда не совсем соответствуют коэф-ам уравнения на диаграмме, а иногда совсем не соответствуют.

Это внутренняя математика Excel и  может быть вызвано целым рядом причин. Основные:

- Значительный разрыв исходных данных. Например есть несколько сот снятых точек от 0 до 10, затем отсутствие снятых точек от 10 до 20, затем несколько сот точек с 20 до 50.

- Значительные степени чисел (как на скрине выше).

Выходом из данной ситуации является следующий макрос-костыль который забирает данные из указанного диапазона ( в примере - "B2:B6"  Данные Х  и "C2:C6" -  Данные Y), строит график, на графике строит линию тренда с заявленной степенью (в примере вторая - Order = 2), копирует строку уравнения, распарсивает её и выкидывает в столбец (  в примере - начиная с ячейки E2 и вниз) коэффициенты полин.уравнения. Построенный график удаляется...

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") ' Данные Y

Set rOut = ActiveSheet.Range("E2") ' Место выгрузки коэф-в

dataLabelText = Извлечение_Полинома(rX, rY)

coefficients = Извлечение_коэффициентов(dataLabelText)

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

'назначаем формат для избежания ошибок при вставке получившихся формул

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

.Value = coefficients

End WithEnd 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 = 2 ' Указываем степень полинома

.DisplayEquation = True

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

dt = Now

DoEvents ' Задержка. См. ниже

DoEvents ' Задержка. См. ниже

Do

If .DataLabel.text <> "" Then Exit Do

If dt < Now - TimeSerial(0, 1, 0) Then Exit Do

For i = 1 To 100: DoEvents: Next

Loop

text = .DataLabel.text

End With

End With

Извлечение_Полинома = text

MyChart.Parent.Delete

End Function

Т.е. делает то, что можно сделать и руками с наглядным выбором вида апроксимации.

Быстрое определение искомого Y по заданному X.

Если Вы уверены в своём глазомере, не боитесь подводных камней и хотите быстро получить значение, то можно воспользоваться вот таким макросом.

Сокращённый вид макроса за авторством БМВ расположен ниже. Расширенный частично на скрине выше. Он понадобится нам в следующем посте, когда будем делать макрос по созданию макросов ), и там будет представлен полностю.

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

Т.е. в функцию передаются столбцы исходных данных, значение Х, при котором требуется найти Y и степень полинома линии тренда.

И да, все заметили что посредством макроса есть возможность построить полином 7-й степени, тогда как линия тренда позволяет выполнять это только до 6-й?

Дальнейшее использование уравнения апроксимации.

Существует всего два подхода:

- Хранить исходные данные на листе. Или в виде таблицы, или в виде уравнения в ячейке.

- Хранить уравнение в виде макроса.

Первый подход удобен при разовом использовании. Если возможно неоднократное использование зависимости, или возможна её модификация, или зависимостей больше десятка - макрос предпочтительнее.

О том как делать макросы для простых графиков, в том числе и в автоматизированном режиме, расскажу в следующий раз.

===========

Краткий план:

Теория вкратце [ Часть 1. ]

Забираем данные с листа. [ Часть 2. ]

Апроксимация простых графиков полиномом средствами Excel [ Часть 3.] Этот пост

Макрос по созданию макросов апроксимации простых графиков полиномом [ Часть 4.]

Апроксимация графиков двух аргументов полиномом [ Часть 5.]

Кусочная интерполяция простых графиков [ Часть 6.]