Макрос для поиска ближайшего значения заданному на всех листах книги Excel
В данном примере предоставлен код VBA-макроса с пояснениями для поиска ближайшего значения указанному на всех листах книги в Excel.
Как найти ближайшее значение заданному на листах книги макросом VBA
Допустим, у нас есть книга Excel, которая содержит некоторое количество листов с таблицами, хранящими различные денные:
В документах, используемых экономистами или бухгалтерами больших предприятий могут храниться огромные таблицы с множеством различных числовых значений. Визуальный просмотр каждой таблицы на каждом листе для поиска ближайшего значения заданному может занять много времени. Чтобы значительно упростить задачу поиска, лучше создать собственный макрос.
Для открытия редактора используйте Alt+F11. В открывшемся окне нажмите правой кнопкой мыши на «Modules», выберите пункт «Insert» и в раскрывшемся списке – пункт «Module»:
Введите код макроса в открывшемся окне для ввода кода:
Sub Module1()
Dim strFindData As String
Dim tempArr() As Integer
Dim rgFound As Range
Dim i As Integer
Dim indexTempArr As Integer
strFindData = InputBox("Введите данные для поиска")
'проверка введенных данных
If IsNumeric(strFindData) = False Then
MsgBox ("Вы ввели не число")
Exit Sub
Else:
strFindData = strFindData * 1
End If
For i = 1 To Worksheets.Count
With Worksheets(i).UsedRange.Cells
Set rgFound = .Find(strFindData, LookIn:=xlValues, LookAt:=xlWhole)
If Not rgFound Is Nothing Then
MsgBox ("Найдено точное совпадение - " & rgFound & " на " & Worksheets(i).Name)
Exit Sub
'поиск ячеек с числовыми значениями и запись этих значений в массив
Else:
For Each cl In Worksheets(i).UsedRange.Cells
If cl <> "" And IsNumeric(cl) Then
ReDim Preserve tempArr(indexTempArr)
tempArr(indexTempArr) = cl.Value * 1
indexTempArr = indexTempArr + 1
End If
Next
End If
End With
Next
'сортировка массива по возрастанию
Dim k As Integer
Dim sortedArr As Variant
sortedArr = SortingArr(tempArr)
Worksheets.Add.Name = "Result"
For l = LBound(sortedArr) To UBound(sortedArr)
Worksheets("Result").Range("B" & l + 1) = sortedArr(l)
Next l
Worksheets("Result").Range("C1").FormulaLocal = _
"=ЕСЛИ(B1<" & strFindData & ";СУММПРОИЗВ(МАКС((B1:B" & UBound(sortedArr) + 1 & _
"<" & strFindData & ")*(B1:B" & UBound(sortedArr) + 1 & ")));B1)"
Dim resultValue As Integer
resultValue = Worksheets("Result").Range("C1").Value
Sheets("Result").Application.DisplayAlerts = False
Worksheets("Result").Delete
MsgBox ("Найдено приближенное значение - " & resultValue)
'MsgBox ("Поиск не дал результатов")
End Sub
Function SortingArr(myTempArr, Optional First As Long = -1, Optional Last As Long = -1) As Variant
Dim i As Long, j As Long, MidEl As Variant, t As Variant
On Error Resume Next
First = IIf(First = -1, LBound(myTempArr), First)
Last = IIf(Last = -1, UBound(myTempArr), Last)
i = First
j = Last
MidEl = myTempArr((First + Last) \ 2)
Do While i <= j
If myTempArr(i) < MidEl Then
i = i + 1
Else
If myTempArr(j) > MidEl Then
j = j - 1
Else
t = myTempArr(i)
myTempArr(i) = myTempArr(j)
myTempArr(j) = t
i = i + 1
j = j - 1
End If
End If
Loop
If First < j Then Call SortingArr(myTempArr, First, j)
If i < Last Then Call SortingArr(myTempArr, i, Last)
SortingArr = myTempArr
End Function
Теперь для поиска ближайшего значения заданному на всех листах можно воспользоваться макросом, для вызова которого необходимо выбрать вкладку «Вид», нажать на кнопку «Макросы» (ALT+F8), в открывшемся окне выбрать название требуемого модуля и нажать «Выполнить»:
В окне нашего пользовательского VBA-макроса введите значение 78 для поиска на всех листах книги. И нажмите ОК:
В результате макрос нас информирует о том, что найдено значение 78 на Лист2:
Теперь введите значение 35 которого нет на листах. Но наш VBA макрос не растерялся. В место традиционного «Значения не найдено :(» он выполнил поиск и нашел нам максимально приблизительное значение к исходному (35):
Теперь чтобы узнать на каком листе находится найденное максимально приближенное значение нам всего лишь нужно еще раз в форму поиска ввести его (29) для повторного поиска.
Логика работы макроса для поиска ближайшего значения заданному на всех листах
В первую очередь организуем ввод данных через InputBox и проверку типа данных, полученных на вход (IsNumeric). Если введено не число, макрос прекратит свою работу с соответствующим сообщением.
Последующий код макроса можно условно разделить на две части: поиск точного совпадения числа и нахождение ближайшего ему значения.
В диапазоне имеющихся значений может находиться число, равное критерию поиска – введенному числовому значению. В этом случае результатом выполнения макроса будет данное число с надписью: «Найдено точное совпадение».
Примечание: поскольку поиск ведется по всем листам книги, используем выражение «For i = 1 To Worksheets.Count» для перебора листов в цикле. Поскольку ячеек на листе может быть огромное множество, с помощью свойства UsedRange организовываем поиск только в используемой области ячеек.
Если точное совпадение не найдено, выполняется участок кода, который выбирает все числовые значения из ячеек всех листов и заполняет ими массив данных tempArr с последующей сортировкой с использованием функции Function QuickSort (реализована отдельно для удобства).
Для упрощения кода, данные из отсортированного массива передаются в ячейки нового листа (Worksheets.Add.Name = "Result") с названием «Result». Затем в соседней ячейке используется формула Excel для поиска ближайшего числа в диапазоне:
Поскольку новый лист необходим только для промежуточных расчетов, полученное максимально приближенное значение передаем в переменную resultValue, а лист «Result» удаляем. Для вывода искомого значения используем метод MsgBox ("Найдено приближенное - " & resultValue).
Полезный совет! Чтобы выполнить макросом поиск по всех листах книги Excel не только числовые значение, а и текстовые измените параметры функции .Find(), которая находится на 29-ой строке кода. Так же не забудьте отключить проверку типа данных IsNumeric(strFindData) закомментировав строки 16-18.
Скачать макрос поиска ближайшего значения на всех листах
Примечание: при выполнении данного макроса могут возникать некоторые ошибки, так как во избежание нагромождения кода в нем были упущены проверки типов данных и некоторые другие условия. Также можно добавить новую функцию, выполняющую поиск ближайшего значения путем перебора элементов массива вместо использования временного листа «Result».
