Серия «Оцифровка»

Потом делал обучающие видосики по использованию одной из моих разработок по облегчению работы для своих сотрудников. Затем меня попросили на планете эксель показать как делается такая "программа" по автоматизации создания макросов, и я стал потихоньку показывать это. Затем возникла проблема - один из подписчиков попытался подцепить то что я написал на пикабу к тому что я показывал в видео, и у него не получилось... Что естественно поскольку все мы меняемся и наши подходы к решению задач меняются... Но он мне напомнил про мою пикабушную серию, и я решил поделиться. Ссыль на плейлист ниже.

https://rutube.ru/plst/651987

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

Сразу скажу - готовых модулей с кодом не дам (почти...). Но весь процесс написания, со всеми узкими местами, будет на видео. На все вопросы отвечу. Ключевое слово - научиться.

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

Ну и все вопросы из "почему рутуб" и "зачем это в эксель" оставляю за бортом. Умеете делать лучше? Рад за вас. Делитесь - готов поучиться.

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

Часть 1. Построение поиска решения.

Итак, у нас есть заданные аргументы (G2, t1в) и результат расчёта Р2. На графике сие будет выглядеть как одна точка с координатами X = G2 = 200 (в нашем примере) и Y = Р2 = 0,065

Существуют минимум три метода построения стрелки поиска:

Вариант 1. Для вертикальной и горизонтальной части строим независимые линии.

После построения настраиваем цвета, указываем наличие стрелки, и т.д.

Для вертикальной линии второй точкой указывается точка с равным значением по Х и минимумом по бумажному графику Y.

Для горизонтальной линии второй точкой указывается точка с равным значением по Y и минимумом по бумажному графику X.

Минимумы и максимумы диаграммы выставляются равными минимумам и максимумам бумажного рисунка.

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

Вариант 2. Единая линия поиска.

Выставление значений дополнительных точек, и значений осей аналогично Варианту 1.

Вариант 3. Использование погрешностей для указания поиска решения.

Если точка одна, то для отображения линий погрешности необходимо перейти в настройки предела погрешности по Х и по Y поочерёдно и...

Отметить

- минус

- без точки

- величина погрешности "пользовательская".

В качестве отрицательной величины погрешности указываем соответственно значение X и Y

Если есть желание получить стрелку направленную к оси Y, а ось Х начинается не с 0 (в нашем случае с 2-ти), то потребуется сделать ячейку рассчитывающую смещение относительно 0.

В нашем примере сделаем такое и для X и Y:

ось Х сдвинута на 20. Соответственно имеем ячейку Хзаданное  -  Хсмещения = 200 - 20

ось Y сдвинута на 0,02 Соответственно имеем ячейку Yзаданное - Yсмещения

Это значения не статичны, т.е. они пересчитаются при изменении исходных данных.

При указании отображения погрешностей ссылаемся на данные ячейки.

Аналогично первым вариантам указываются свойства линий.

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

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

Однако можно сделать выноску для той самой, единственной точки.

Результаты всех трёх способов не сильно отличаются:

Часть 2. Совмещение построенного графика с изначальным рисунком.

И опять есть минимум три варианта.

Вариант 1. Использование рисунка в качестве подложки под областью построения (то, что расположено внутри границ осей). Для этого рисунок сначала подготавливается (обрезается по размерам построения, при этом подписи осей оказываются обрезанными), а затем вставляется по пути: Формат области построения – Заливка – Рисунки и текстура – Файл / из буфера обмена;

Вариант 2. Использование рисунка в качестве подложки области диаграммы (вкладка Формат области диаграммы – Заливка – Рисунки и текстура - Файл) вставляется рисунок графика (предварительно подготовленный и очищенный. Необходимо также учитывать, что потребуется некоторая ширина полей для выставления подписей). Совмещаются границы графика Excel с границами графика рисунка перетягиванием за маркеры границы графика (перемещение указал стрелками).

выставляются границы осей графика Excel в соответствии с границами графика (если не выставили ранее). При необходимости производится отключение отображения подписей осей, сетка и название диаграммы.

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

при необходимости можно построить дополнительную линию. В качестве примера построена дополнительная кривая при 40°С при помощи созданной пользовательской функции при заданной температуре 40°С и переменной влажности. Аналогично построена дополнительная линия на первом рисунке

Вариант 3. При третьем варианте рисунок вставляется на лист Excel, построенный график/ подготовленная диаграмма размещается над рисунком, при этом заливка поля построения и самой диаграммы "отсутствует" или "прозрачная". После совмещения изображение и диаграмма фиксируются между собой как это было указано в посте "Нестандартные заголовки диаграмм".

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

Отдельно стоят диаграммы состоящие из расположенных рядом двух и более диаграмм.

Их оформление, опять же, может быть реализовано тремя способами.

Способ 1 - применение третьего варианта наложения диаграмм на рисунок (описано выше). Т.е. строим два независимых графика для левой и правой части, делаем их прозрачными и накладываем на рисунок.

Способ 2 - применение первого варианта, наложение графика на область построения (описано выше). Т.е. строим два независимых графика для левой и правой части, накладываем области построения и размещаем взаимно друг другу до совпадения минимума и максимума.

Способ 3. - пригоден только для расположенных рядом двух диаграмм. Данный способ позволяет избавится от стыка, неизбежно возникающего при первых двух способах. Основано как правило на применении второго варианта описанного выше, а именно использовании рисунка как подложки под диаграммой.

Рассмотрим один из вариантов построения стрелки на диаграмме, состоящей из двух диаграмм, при этом ширина клеток и величина шага для правого и левого графика разная.

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

Шаг 1. Построение левого графика (синий график, синяя ось, синие данные).

1. Построить точечный график по исходным данным, причём заложить небольшой перехлёст по Х (установлено 80 вместо 70-ти по рисунку);

2. Сделать подложку под диаграмму (используется весь рисунок, без обрезок или разделения на две части);

3. Растянуть область построения на рисунок;

4. Задать значения оси (диапазон) Y в соответствии с оцифровкой;

5. Задать значения оси (диапазон) Х таким образом, чтобы Хмин было равно минимальному значению на рисунке (30), а Хмакс подобрать таким образом, чтобы совпали значения рисок (40=40, 50=50, 60=60, 70=70).

Шаг 2. Построение правого графика (красный график, красный ось, красный данные).

1. Построить точечный график по исходным данным, причём минимум Х заложить равным минимуму по второй оси (0);

2. Указать построение по вспомогательным осям;

3. Задать значения вспомогательной оси (диапазон) Y в соответствии с оцифровкой;

4. Задать значения оси (диапазон) Х таким образом, чтобы Хмакс было равно максимальному значению по второй оси рисунка, а Хмин подбрать таким образом, чтобы начало второго графика легло на минимум второй оси Х рисунка.

Шаг 3. Убрать отображение подписей осей, сетки и т.д. Настроить цвета линий.

============================

Для кого то это покажется элементарным, но я на своей практике не один раз ломал голову как выполнить графическое оформление поиска решения. Базовыми знаниями поделился. Всё дальнейшее зависит от вас. Будут вопросы - помогу по мере сил.

Пожалуй на этом закончим и серию Excel. Долгая дорога оцифровки. Всё обещанное показал, а именно:

1. Теория

2. Снятие данных с рисунка

3. Апроксимация простых графиков

4. Макрос по созданию макросов простых функций

5. Создание макроса функции двух аргументов

6. Кусочная интерполяция

7. Макрос по созданию макросов на основе кусочной интерполяции

8. Обратная функция или поиск корней

9. Отображение поиска решения (данный пост).

Ввиду особенностей оцифровки есть два основных варианта решения данного вопроса

Вариант 1. Если сохранены данные "снятия точек", и зависимость монотонна как на рисунке выше, то самым простым решением является  поменять снятые точки Х и Y и создать новый макрос.

Вариант 2. Решение задачи Y(x) - Yзад = 0, что так же может выполняться разными способами.

Существует множество численных решение данной задачи: метод половинного деления, метод Ньютона, метод... в общем методов достаточно много, и все несложно реализуются, например вот макрос поиска решения Y_ot_X(x) - Yзад = eps. методом половинного деления Где Y_ot_X(x) - известный макрос расчёта простой функции, а eps - точность поиска решения.

Public Function X_po_Y_polovin(Y As Single) As Single

Dim Xmin As Single: Xmin = 0 ' Минимальная граница поиска

Dim Xmax As Single: Xmax = 350 ' Максимальная граница поиска

Dim Xisk As Single ' Переменное значение искомого Х

Dim dX As Single: dX = 0.00001 ' Точность поиска по X

Dim dY As Single: dY = 0.00001 ' Точность поиска по Y

Do While (Xmax - Xmin) > dX

Xisk = (Xmax + Xmin) / 2

If Abs(Y_ot_X(Xisk) - Y) < dY Then Exit Do

If (Y_ot_X(Xmin) - Y) * (Y_ot_X(Xisk) - Y) < 0 Then

Xmax = Xisk

Else

Xmin = Xisk

End If

Loop

X_po_Y_polovin = Xisk

End Function

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

Вот так выглядит макрос выполняющий поиск решения при помощи метода половинного деления для функции 2-х аргументов.

' НТД ТЭЦ12 ПТ9 Диаграмма режимов 2ст.режим нижний график

' Определение Nф по N и Qт

Public Function НТД_ТЭЦ12_ПТ9_ПТ2_QпМАКС(Nф As Single, Qт As Single) As Single

Dim Xmin As Single: Xmin = 0# ' Минимальная граница поиска

Dim Xmax As Single: Xmax = 200# ' Максимальная граница поиска

Dim Xisk As Single ' Переменное значение искомого Х

Dim dX As Single: dX = 0.001 ' Точность поиска по X

Dim dY As Single: dY = 0.001 ' Точность поиска по Y

' Обязательно проверка выхода за границы.

If Qт > НТД_ТЭЦ12_ПТ9_ПТ2_GтпоNфQпмакс(Nф, 0) Then

НТД_ТЭЦ12_ПТ9_ПТ2_QпМАКС = 0

Else

Do While (Xmax - Xmin) > dX

Xisk = (Xmax + Xmin) / 2

If Abs(НТД_ТЭЦ12_ПТ9_ПТ2_GтпоNфQпмакс(Nф, Xisk) - Qт) < dY Then Exit Do

If (НТД_ТЭЦ12_ПТ9_ПТ2_GтпоNфQпмакс(Nф, Xmin) - Qт) * (НТД_ТЭЦ12_ПТ9_ПТ2_GтпоNфQпмакс(Nф, Xisk) - Qт) < 0 Then

Xmax = Xisk

Else

Xmin = Xisk

End If

НТД_ТЭЦ12_ПТ9_ПТ2_QпМАКС = Xisk

Loop

End If

End Function

Рассмотрим диаграмму зависимости от двух аргументов Qт = f(Nт, Qтmax). И наша задача определить значение Qтmax при известных Qт и Nт. Макрос поиска с помощью половинного деления приведён выше.

И вот тут начинается особенность оцифровки - мы можем с уверенностью сказать и проверить значение функции только в области представленного графика. Т.е. проще говоря - данных о значениях при Qпmax = 120 и Nт < 39 у нас нет. В этой зоне имеет место экстраполяция данных, и как поведёт функция при экстраполяции зависит от того как мы провели оцифровку. В данном случае (данной номограммы) особого влияния может и не будет, но есть варианты, что экстраполированная с помощью  полинома функция искривиться и значение при Qпmax = 120 и Nт = 20 будет больше чем при Qпmax = 0 и Nт = 20. Т.е. и метод половинного деления отработает не верно.

Поэтому два простых правила:

1. При проведении оцифровки внимательно относитесь к экстраполяции. В идеале - кусочная интерполяция с использованием линейной интерполяции для начала и окончания графика.

2. Если расчётов мало - используйте метод перебора.

Public Function X_po_Y_perebor(Y As Single) As Single

Dim Xmin As Single: Xmin = 0 ' Минимальная граница поиска

Dim Xmax As Single: Xmax = 350 ' Максимальная граница поиска

Dim dX As Single: dX = 0.001 ' Шаг поиска

Dim dY As Single: dY = 0.00001 ' Точность поиска

Dim Xisk As Single ' Переменное значение искомого Х

For Xisk = Xmin To Xmax Step dX

If Abs(Y_ot_X(Xisk) - Y) < dY Then

X_po_Y_perebor = Xisk

Exit For

Else

X_po_Y_perebor = 0

End If

Next Xisk

End Function

Пример перебора для функции двух аргументов

fun_TEC25_PT60_Prez_G0poGsd(N, i) - известная ф-я поиска Gо по N и Gsd

G0 - известно

N - известно

Gsd - требуется найти

For i = 0 To 300 Step 0.01 - ищу от 0 до 300 с шагом 0,01

< 0.1 - достаточная (для примера) точность поиска.

Public Function fun_TEC25_PT60_Prez_Gsd_poG0N(G0 As Single, N As Single) As Single

Dim i As Single

fun_TEC25_PT60_Prez_Gsd_poG0N = 0 'Если решение не будет найдено - будет выведен 0

For i = 0 To 300 Step 0.01

If Abs(fun_TEC25_PT60_Prez_G0poGsd(N, i) - G0) < 0.1 Then

fun_TEC25_PT60_Prez_Gsd_poG0N = i

Exit For

End If

Next i

End Function

Поиск всех корней уравнения, заданного таблично

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

Option Base 1 ' Иначе смотреть корень с второго элемента

Function РешенУравн(МассивX, МассивY)

' Возвращает корень(корни) уравнения Y(X) = 0

' МассивX - монотонно или возрастает, или убывает

Dim Xs() As Double, Ys() As Double, XEs() As Double, Num, N As Long, M As Long, K As Long

МассивX = МассивX

МассивY = МассивY

ReDim Xs(2 ^ 10), Ys(2 ^ 10), XEs(2 ^ 8)

For Each Num In МассивX

K = K + 1: Xs(K) = Num

Next

N = K: K = 0

For Each Num In МассивY

K = K + 1: Ys(K) = Num

Next

If K <> N Then Exit Function' если длина МассивY <> длине МассивX

For K = 1 To N - 1

If Ys(K) = 0 Then

M = M + 1: XEs(M) = Xs(K)

Else

If Ys(K) * Ys(K + 1) < 0 Then

M = M + 1

XEs(M) = (Ys(K) * Xs(K + 1) - Xs(K) * Ys(K + 1)) / _

(Ys(K) - Ys(K + 1))

End If

End If

Next

If K = N Then

If Ys(N) = 0 Then

M = M + 1: XEs(M) = Xs(N)

End If

End If

If M = 1 Then

РешенУравн = XEs(1)

ElseIf M > 1 Then

ReDim Preserve XEs(M) ' если корней несколько - массив

РешенУравн = WorksheetFunction.Transpose(XEs)

Else ' корней в диапазоне МассивX нет

РешенУравн = CVErr(xlErrNA)

End If

Exit Function

End Function 'РешенУравн'

Макрос не мой. Взят из открытых источников на просторах интернета, но первоисточник у меня не сохранился (к моему огорчению - стараюсь всегда указывать авторов).

=======================

dixi

За сим тему оцифровки считаю на 80% закрытой. Всегда есть то, что относится к конкретной работе, и не всегда подлежит огласке. Если будут вопросы - постараюсь ответить. В меру знаний естественно.

Для тех кто считает что "не надо изобретать велосипед" - прошу привести примеры подобного в свободном бесплатном доступе. Я знаю (встречался) с платными надстройками, о бесплатных не в курсе. Буду рад расширить кругозор.

Тех кто считает что "надо пользоваться пайтоном/матлабом/маткадом/... Ибо там всё есть и проще" хочу огорчить - придя на работу у Вас не всегда есть эти мат.пакеты. Вы не всегда имеете возможность их установки (хоть лицензия, хоть пиратка, хоть триал). Просто запрет компании. И при этом задача должна быть решена. И решена ни один или два раза. Вы можете распечатать и ползать с карандашом и линейкой по диаграммам. А можете перевести в цифру. Как показала практика - оцифровка вполне реализуется, и на 100% работа может быть выполнена в Excel. Без дополнительных надстроек. И даже если Вы решили задачу на своём, личном компе - остаётся вопрос передачи расчёта заказчику, или в вышестоящую инстанцию.

Ну а в следующий раз будем строить стрелочки на рисунках :)

Описание вводимых данных аналогично ранее изложенному.

Если ещё немного развить тему, то и макрос создания макросов функции с двумя аргументами не проблема:

Отличием от вводимых ранее данных является требование указания критериев через точку с запятой.

Основное нововведение - определение количества графиков. Если вспомните ещё в Excel. Долгая дорога оцифровки. Часть 2. Забираем данные с листа я писал, что что "снятие точек производить от меньшего Х к большему. При наличии диаграммы зависимости от двух аргументов типаY(X1, X2) начиная с графика меньшего Х2. С обязательным условием - каждая следующая линия должна начинаться с Х меньшего, чем закончилась предыдущая.". И теперь можно этим воспользоваться - определить количество переходов на новую линию по уменьшению Х по сравнению с предыдущим.

For i = 2 To xVal.Count

If i = xVal.Count Then

Nkon(Ndiap) = i

End If

If xVal.Rows(i) < xVal.Rows(i - 1) Then

Nkon(Ndiap) = i - 1

Ndiap = Ndiap + 1

Nna4(Ndiap) = i

End If

Next i

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

Результирующий макрос будет иметь вид:

' Поправки Сербия Панчево Страница 34 из 77 Нижний рисунок

Public Function ТЭХ_ПТ80_Рис3(ByRef Go As Single, ByRef CkH As Single) As Single

Dim krit_kriv As Variant

krit_kriv = array(2.96,3.06,3.15)

Dim kriv As Variant

kriv = Array(-0.00271242 * Go + 0.100817, _

-0.00252906 * Go + 0.230858, _

0.000276671 * Go ^ 2 -0.203078 * Go + 31.5862)

ТЭХ_ПТ80_Рис3= kus_interp(krit_kriv, kriv, CkH, 2)

End Function

Не забываем удалять кавычки в начале и конце макроса при копировании в модуль.

Давайте так, чтобы не утомлять читателя выкопировкой текстовок макросов - выкладываю сие для свободной скачки/использования/модернизации

Если возникнут вопросы как сие работает, распишу. Если у кого то что то не заработает - обращайтесь, посмотрю.

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

За сим тему с оцифровкой считаю закрытой. Все базовые функции показал. С помощью данных функций, а так-же их комбинаций и расширений можно сделать автоматическую оцифровку совершенно разнообразных конфигураций диаграмм.

Например диаграмма с несколькими независимыми графиками типа такой. Можно либо сделать 3 независимых макроса, либо один с выбором графика.

С помощью автоматического создания макросов

Позволит получить (текстовка от графика отличного от представленного выше рисунка)

' ТЭХ ПТ80 Рис.3 Давление в отборах при конденсационном режиме [МПа]

Public Function ТЭХ_ПТ80_Рис3(ByRef Go As Single, ByRef Название_графика As Variant) As Variant

Dim krit_graph As Variant

krit_graph = array(1,2,3)

Select Case Название_графика

Case krit_graph(0)

ТЭХ_ПТ80_Рис3 = -0.0027124 * Go ^ 1 + 0.10082

Case krit_graph(1)

ТЭХ_ПТ80_Рис3 = -0.0025397 * Go ^ 1 + 0.23509

Case krit_graph(2)

ТЭХ_ПТ80_Рис3 = -0.0026659 * Go ^ 1 + 0.4529

Case Else

ТЭХ_ПТ80_Рис3 = 999999999999999

End Select

End Function

При желании указывать название графика правится krit_graph = array("Go","Qo","qt").

Ну и гораздо более сложноподчинённые, например что реализовано у меня:

Диаграммы режимов ПТ типа ПТ-80

Диаграммы режимов типа Т-250

Нормативной температуры сетевого подогревателя.

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

Из того на что стоит обратить внимание, или маленькие лайфхаки:

1. Не всегда есть разметка осей. Например на диаграмме на последнем скрине вертикальная ось не размечена. Но она в данном случае не нужно. Важно иметь одинаковое значение для левого и правого графиков. Как правило я принимаю в качестве минимального значения оси - 0, в качестве максимального - число клеток (например 12-ть).

2. Внимание! Ось Х не обязательно горизонтальная при "снятии точек"! Например на диаграмме на последнем скрине  для правого графика удобно взять в качестве оси Х вертикальную ось а в качестве Y - горизонтальную. Тогда результат обработки левой номограммы будет сразу выступать в качестве аргумента для правой номограммы.

3. Есть варианты оцифровки, когда лучше привязываться не к значениям осей, а к клеточкам :) Да, звучит дико, но иногда проще внести пересчёт внутри макроса, чем реализовать оцифровку по данным осей.  Например диаграмма ниже - обратите внимание, что вертикальная ось не обозначена, зато горизонтальная в левой диаграмме разбита на 3 участка с разным масштабом.

Упд. Вспомнил ещё про важную часть - обратные функции. Т.е. есть макрос (готовый!), который по известным Х1, Х2... находит Y. Иногда требуется с использованием данного макроса и известных Y и X1 найти X2... Но об этом в следующий раз. А то и так пост разросся.

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

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

====

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

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

' Данные из листа 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.]