Уважаемые эксперты по Excel и VBA! Многие часы ломаю голову, пытаясь написать пользовательскую функция с помощью разбора обозначений формул при записывании макроса, но все бес толку. В работе часто приходится использовать достаточно большую формулу массива для поиска значения в диапазоне на пересечении ближайших больших значений по строкам и столбцам:
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, да. Дело в том, что мне часто приходится использовать различные варианты данной формулы (поиск может быть ближайшего меньшего значения или диапазон поиска может быть только по ДИАПАЗОН_X и т.д.). И мне хотелось быть получить пользовательскую функцию, на основе которой я смог бы создавать подобные.
Наша суть отражается в наших повторяющихся действиях. Отсюда следует, что совершенство есть не действие, а привычка. Аристотель.
ну вот, блин, только начал))) сразу надо такое говорить)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Юрий М, нет, прошу прощения. Нажал кнопку "создать" немного раньше времени, а отредактировать название уже не получается . Тема: Помощь при создании пользовательской функции в VBA с использованием стандартных формул EXCEL Описание: В коде хотелось бы использовать стандартных формул EXCEL для возможности самостоятельного редактирования
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Юрий М,мне кажется #6, так как сам по себе "Поиск пересечения в кросс-таблице по 2м неточным числовым значениям осей" у меня имеется, а вот как из него пользовательскую функцию составить - неясно .
Вот хороший вариант : Пользовательская функция VBA: поиск пересечения в кросс-таблице по 2-м неточным числовым значениям осей.
я за своё - у ТС может что-то и есть, но явно не то, что нужно, а по его названию никто ничего не найдёт. После решения, я ещё и другую давнюю тему обновлю, в которой так до сих пор ничего внятного не написал … Valo, без обид (про название) - ничего против вас не имею - договорились?
UPD: Так всё-таки «Пользовательская функция» или «Стандартные формулы EXCEL в VBA»??? Вы знаете, что это разные вещи? UDF я напишу, а по формулам пас…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Не могу понять, что не так. Прошу помощи у знатоков. Сортировка работает (закомментировано)
Собсна КОД
Код
Option Explicit
Public Function GetClose(valX, valY, rngX As Range, rngY As Range)
Dim cl As Range
Dim arrX, arrY, x, y, x1, x2, xFind, y1, y2, Yfind
Dim r&, c&
Dim txtX$, txtY$ ', delim$
On Error GoTo er
arrX = rngX.Value: arrX = TransposeArray(arrX): arrX = SortArr(arrX)
arrY = rngY.Value: arrY = SortArr(arrY)
'delim = "•"
' For Each x In arrX
' txtX = txtX & x & delim
' Next x
' For Each y In arrY
' txtY = txtY & y & delim
' Next y
'GetClose = txtX & "|" & txtY
'ищем ближайший X =================================================================
For Each x In arrX
If x < valX Then x1 = x
If x = valX Then xFind = x: GoTo contX
If x > valX Then x2 = x: GoTo nxX
Next x
nxX: If Abs(x1) - Abs(x) < Abs(x2) - Abs(x) Then xFind = x1 Else xFind = x2
'ищем ближайший Y =================================================================
contX:
For Each y In arrY
If y < valY Then y1 = y
If y = valY Then Yfind = y: GoTo contY
If y > valY Then y2 = y: GoTo nxY
Next y
nxY: If Abs(y1) - Abs(y) < Abs(y2) - Abs(y) Then Yfind = y1 Else Yfind = y2
'ищем пересечение =================================================================
contY: r = 0: c = 0
For Each cl In rngX
If cl.Value = xFind Then r = cl.Row: GoTo nx1
Next cl
nx1:
For Each cl In rngY
If cl.Value = Yfind Then c = cl.Column: GoTo nx2
Next cl
If r = 0 Or c = 0 Then GoTo er
nx2:
GetClose = Cells(r, c).Value
GoTo fin
er:
GetClose = "ОШИБКА"
fin:
End Function
'===================================================================================================================
'Сортировка двумерного массива (http://excelvba.ru/code/SortArray)
'===================================================================================================================
Public Function SortArr(SourceArr As Variant, Optional ByVal N As Integer = 1) As Variant
' сортировка двумерного массива по столбцу N
If N > UBound(SourceArr, 2) Or N < LBound(SourceArr, 2) Then _
MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function
Dim Check As Boolean, iCount As Integer, jCount As Integer, nCount As Integer
ReDim tmpArr(UBound(SourceArr, 2)) As Variant
Do Until Check
Check = True
For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
If Val(SourceArr(iCount, N)) > Val(SourceArr(iCount + 1, N)) Then
For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
tmpArr(jCount) = SourceArr(iCount, jCount)
SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
SourceArr(iCount + 1, jCount) = tmpArr(jCount)
Check = False
Next
End If
Next
Loop
SortArr = SourceArr
End Function
'===================================================================================================================
'Функция VBA для транспонирования массива (http://excelvba.ru/code/Transpose)
'===================================================================================================================
Public Function TransposeArray(ByVal arr As Variant) As Variant
' Пользовательская функция для транспонирования массива
Dim tempArray, x, y
ReDim tempArray(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For x = LBound(arr, 2) To UBound(arr, 2)
For y = LBound(arr, 1) To UBound(arr, 1)
tempArray(x, y) = arr(y, x)
Next y
Next x
TransposeArray = tempArray
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
vikttur, я просто стараюсь найти решение максимально универсальное (как всегда) и, при этом, предельно понятное (христоматийное, если угодно) В данном случае я старался учесть не только целые положительные числа, но и отрицательные, и дробные и, возможно, даже текст (не тестил) Для данного случая подойдёт обычный цикл по двум диапазонам — обещаю сделать
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
vikttur написал: Зачем сортировка и транспонирование?
транспонирование для того, чтобы можно было сортировать (иначе не работает, потому что сортировка по СТОЛБЦУ). Сортировка для того, чтобы циклом перебирать варианты до бОльшего заданного и брать 2: бОльше заданного и предыдущее, после сравнивая отклонение. Я пробовал вариант, где числа расположены не по порядку — отсюда и сортировка. В рамках данной задачи - излишне, но, если бы у меня получилось, то было бы намного универсальнее и ненамного дольше Вы мне подали идею))) несколько "служебных" функций, вызываемых основной, в зависимости от параметров основной попробую попробовать)))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Сравнение по указанному знаку. Если последний параметр не указан, сравнение по знаку ">" Проверка на правильность сравнения (при выходе за пределы указанных значений) не прописана. Например, при поиске y=3 к выборке данных подготовится строка 1, а это шапка со значениями х; при у=45 тоже ошибка. Это поле деятельности для разработчика
Код
Function fMinMax(rRng As Range, yVal As Long, xVal As Long, Optional sStr As String = ">") As Long ' если дробные - Double
Dim bFlag As Boolean
Dim i As Long, j As Long
i = 1: j = 1
If sStr = "<" Or sStr = "<=" Then bFlag = True
Do
i = i + 1
Loop Until Evaluate(rRng(i, 1) & sStr & yVal) <> bFlag
Do
j = j + 1
Loop Until Evaluate(rRng(1, j) & sStr & xVal) <> bFlag
fMinMax = rRng(i + bFlag, j + bFlag).Value
End Function
Обычно избегаю применения логических значений при сложении/вычитании. Но тут такое решение показалось уместным.