Мне нужна помощь в составлении макроса VBA, который сократит существующую формулу интерполяции. Формула выделена оранжевым цветом, а все составляющие в интерполяции — голубым.
Приведенный ниже код не работает, и я был бы очень признателен за вашу помощь в решении этой проблемы. В VBA я пока не очень разбираюсь.
Заранее благодарю за вашу помощь!
Код
Function Интерполяция(ДиапазонA As String, ДиапазонB As String, ДиапазонДанных As String, F19 As Double, F22 As Double, F24 As Double) As Variant
Dim A As Range, B As Range, Data As Range
Dim TargetValue As Double
Dim MinA As Double, MaxA As Double
Dim RowIndex As Long, ColIndex As Long
Dim MinB As Double, MaxB As Double
Dim ColIndexMax As Long
Dim Y1 As Double, Y2 As Double
Dim MinA_found As Boolean, MinB_found As Boolean, MaxB_found As Boolean
' Устанавливаем диапазоны
On Error Resume Next
Set A = Range(ДиапазонA)
Set B = Range(ДиапазонB)
Set Data = Range(ДиапазонДанных)
On Error GoTo 0
' Проверяем, что диапазоны корректны
If A Is Nothing Or B Is Nothing Or Data Is Nothing Then
Интерполяция = CVErr(xlErrRef) ' Возвращаем ошибку ссылки
Exit Function
End If
' Проверяем, что все значения числовые
If Application.WorksheetFunction.Count(A) <> A.Count Or _
Application.WorksheetFunction.Count(B) <> B.Count Or _
Application.WorksheetFunction.Count(Data) <> Data.Count Then
Интерполяция = CVErr(xlErrValue) ' Возвращаем ошибку значения
Exit Function
End If
' Рассчитываем целевое значение
TargetValue = Application.WorksheetFunction.Average(F22, F24)
' Находим минимальное значение в A, которое больше или равно F19
On Error Resume Next
MinA = Application.WorksheetFunction.Min(Evaluate("IF(" & ДиапазонA & ">=" & F19 & "," & ДиапазонA & ", """")"))
RowIndex = Application.Match(MinA, A, 0)
On Error GoTo 0
' Проверяем, чтобы RowIndex был валиден
If RowIndex <= 0 Or RowIndex > A.Rows.Count Then
Интерполяция = CVErr(xlErrValue)
Exit Function
End If
' Находим минимальное значение в B, которое больше или равно TargetValue
On Error Resume Next
MinB = Application.WorksheetFunction.Min(Evaluate("IF(" & ДиапазонB & ">=" & TargetValue & "," & ДиапазонB & ", """")"))
ColIndex = Application.Match(MinB, B, 0)
On Error GoTo 0
' Проверяем, чтобы ColIndex был валиден
If ColIndex <= 0 Or ColIndex > B.Columns.Count Then
Интерполяция = CVErr(xlErrValue)
Exit Function
End If
' Находим максимальное значение в B, которое меньше или равно TargetValue
On Error Resume Next
MaxB = Application.WorksheetFunction.Max(Evaluate("IF(" & ДиапазонB & "<=" & TargetValue & "," & ДиапазонB & ", """")"))
ColIndexMax = Application.Match(MaxB, B, 0)
On Error GoTo 0
' Проверяем, чтобы ColIndexMax был валиден
If ColIndexMax <= 0 Or ColIndexMax > B.Columns.Count Then
Интерполяция = CVErr(xlErrValue)
Exit Function
End If
' Получаем значения для интерполяции
Y1 = Data.Cells(RowIndex, ColIndex)
Y2 = Data.Cells(RowIndex, ColIndexMax)
' Проверяем, что TargetValue находится между MinB и MaxB
If TargetValue < MinB Or TargetValue > MaxB Then
Интерполяция = CVErr(xlErrValue) ' Возвращаем ошибку значения
Exit Function
End If
' Интерполяция
Интерполяция = Y1 + ((TargetValue - MinB) / (MaxB - MinB)) * (Y2 - Y1)
End Function
Легче не стало...В приложенном файле есть UDF ВЫЧСПОД, которая, в свою очередь, расположена в надстройке C:\Users\korolnik\AppData\Roaming\Microsoft\AddIns\формулы.xla Без нее кроме '#ИМЯ?' в ячейках ничего нет) Соберите все в один файл. На разные листы. Исходные данные, функции, которые нужны для расчетов, лист для вывода результатов. Короче, приготовьте нормальный файл-ПРИМЕР
Function Интерполяция2(ДиапазонA As Range, ДиапазонB As Range, ДиапазонДанных As Range, F19 As Double, F22 As Double, F24 As Double) As Variant
Dim aДиапазонДанных As Variant
Dim aДиапазонA As Variant
Dim aДиапазонB As Variant
Dim res As Double
Dim y1 As Double
Dim y2 As Double
Dim x1 As Double
Dim x2 As Double
Dim yy As Double
Dim xx As Double
aДиапазонДанных = ДиапазонДанных.Value
aДиапазонA = ДиапазонA.Value
aДиапазонB = ДиапазонB.Value
yy = WorksheetFunction.Match(F19, aДиапазонA, 1) + 1
xx = myMatch((F22 + F24) / 2, aДиапазонB) + 1
y1 = aДиапазонДанных(yy, xx)
y2 = aДиапазонДанных(yy, xx - 1)
xx = myMatch((F22 + F24) / 2, aДиапазонB)
x1 = aДиапазонB(1, xx)
x2 = aДиапазонB(1, xx + 1)
xx = (F22 + F24) / 2
Интерполяция2 = y1 + (xx - x1) * (y2 - y1) / (x2 - x1)
End Function
Private Function myMatch(dd As Double, arr As Variant) As Long
Dim ii As Long
Dim vv As Variant
For Each vv In arr
ii = ii + 1
If vv > dd Then
myMatch = ii
End If
Next
End Function
МатросНаЗебре, Так как рабочая точка, значения "192..." и "942..." находятся в диапазоне между режимами оборотов в "2030" и "2600". Пожалуйста, посмотрите на диаграмму, где я обозначил эти значения стрелочками Колонка (КПД ПЭН'!V:V) относится к числу оборотов 2600, а колонка 'КПД ПЭН'!U:U. к числу оборотов 2030
МатросНаЗебре, Да, только на снимке. Вы хотите сказать, что нужно создать проверку на удовлетворение условия: если колонка, допустим, 2030, имеет значение 192 и больше, в которой имеется значение данных, равное или больше 942?
С учётом того, что в файле были некие формулы, вроде y = -0,000018518519x3 + ... была слабая надежда, что связь между этими величинам задана аналитически, ну или хотя бы таблично. Но если только на графике, то, как минимум не хватает "оцифровки" этого графика.
Цитата
написал: Вы хотите сказать, что нужно создать проверку на удовлетворение условия: если колонка, допустим, 2030, имеет значение 192 и больше, в которой имеется значение данных, равное или больше 942?
Не уверен, потому что я не понимаю, что тут написано
МатросНаЗебре, а ну и да, данные формулы ( уравнения тренда) тоже связаны со значением 192🙄 рядом с таблицей есть диаграмма, она целиком повторяет диаграмму указанную в картинке (10)
Ну допустим. У нас есть точка 192. Будем считать, что это где-то рядом с 200, а следовательно, это как-то связано с диапазоном U7:X7. Очевидно, что надо выбрать из этих 4 значений. Как это делаете?
MaxGromov, Извините, но со своей колокольни (такой работой по переводу бумажных номограмм в UDF занимаюсь более пяти лет. Точнее собственно оцифровка это часть работы) я могу сказать что у Вас совершенно не верный подход к решению задачи. Это если у вас траблы с расчётами ТЭП только для кондёра, то боюсь представить как вы реализуете полноценную оцифровку НТД или ТЭХ с парой сотен номограмм для каждого турбоагрегата. А уж про формирование функции четырёх аргументов (например qt для ПТ80) будет чем то своебразным непереносимым. Переводите всё (включая исходные данные) в UDF и не парьте мозг. Как сие делать показывал на пикабу (ага, самый тот ресурс для этого ), и частично тут - на данном форуме, там все ссылки есть.
Прошу понять правильно - это не ответ на вопрос "как переделать существующий макрос", а рекомендация по изменению подхода в целом.
Для понимания - вот так сейчас (почти..) у меня выглядит автоматическая оцифровка . Сразу скажу - программу не дам. А о основах - ссылка выше.
Ну и для подумать: А кто сказал что интерполяция между критериев (в данном случае частота вращения) линейна? Побаловался я с вашим рисунком, и вот что получается: если взять и посчитать при расходе 200 куб.м/ч в заданных критериях, то получим четыре точки лежащие не на прямой линии. Теперь посчитаем напор меж заданных критериев. Например напор при 2300об/мин и линейной интерполяцией (по двум точкам) будет 706 метров, а если взять, например, три , то напор уже 696м. На 10м меньше. А это более 1% отклонение. Ну и т.д.
Ну это так, подумать.
А вообще в данном случае можно и без макроса. См.приложение.