Vba excel найти во всех листах

I have written a macro which will search for a string in all the sheets of an Excel workbook. This macro will activate the first sheet as well as the cell in the sheet which contains the search string. If not found, then it will show a message.

I want to extend this functionality to cover all the sheets which contain this string and not just the first one. So I modified the macro, but it is not working as expected. I have given the code below and also commented at the place where it is showing the error.

Dim sheetCount As Integer
Dim datatoFind

Sub Button1_Click()

Find_Data

End Sub

Private Sub Find_Data()
    Dim counter As Integer
    Dim currentSheet As Integer
    Dim notFound As Boolean
    Dim yesNo As String

    notFound = True

    On Error Resume Next
    currentSheet = ActiveSheet.Index
    datatoFind = InputBox("Please enter the value to search for")
    If datatoFind = "" Then Exit Sub
    sheetCount = ActiveWorkbook.Sheets.Count
    If IsError(CDbl(datatoFind)) = False Then datatoFind = CDbl(datatoFind)
    For counter = 1 To sheetCount
        Sheets(counter).Activate

        Cells.Find(What:=datatoFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate

        If InStr(1, ActiveCell.Value, datatoFind) Then
            If HasMoreValues(counter + 1) Then 'Not completing the method and directly entering
                yesNo = MsgBox("Do you want to continue search?", vbYesNo)
                If yesNo = vbNo Then
                    notFound = False
                    Exit For
                End If
            End If
            Sheets(counter).Activate
        End If
    Next counter
    If notFound Then
        MsgBox ("Value not found")
        Sheets(currentSheet).Activate
    End If
End Sub

Private Function HasMoreValues(ByVal sheetCounter As Integer) As Boolean
    HasMoreValues = False
    Dim str As String

    For counter = sheetCounter To sheetCount
        Sheets(counter).Activate

        str = Cells.Find(What:=datatoFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Value 'Not going further than this i.e. following code is not executed

        If InStr(1, str, datatoFind) Then
            HasMoreValues = True
            Exit For
        End If
    Next counter
End Function

1
2
3
4

Private Sub ListBox1_Click()
    If ListBox1.ListIndex = -1 Then Exit Sub
    Cells(ListBox1.Value, 1).Select
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

Private Sub TextBox1_Change()
Dim j As Long, i As Long
ListBox1.Clear
'при отсутствии символов для поиска - выход
   If Len(TextBox1.Value) = 0 Then Exit Sub   
   j = 0
'для одного символа поиск осуществляем по первой букве
If Len(TextBox1.Value) = 1 Then
    For i = 7 To Cells(Rows.Count, 1).End(xlUp).Row
        If UCase(Left(Cells(i, 1), 1)) = UCase(TextBox1.Value) Then
            ListBox1.AddItem i
            ListBox1.List(j, 1) = Cells(i, 1)
            j = j + 1
        End If
    Next i
    'если найден только один эл-т, то переходим к нему
    If j = 1 Then Cells(ListBox1.List(0, 0), 1).Select
    Exit Sub
End If 
For i = 7 To Cells(Rows.Count, 1).End(xlUp).Row
    If InStr(1, UCase(Cells(i, 1)), UCase(TextBox1.Value)) > 0 Then
       ListBox1.AddItem i
       ListBox1.List(j, 1) = Cells(i, 1)
       j = j + 1
    End If
Next i
   'если найден только один эл-т, то переходим к нему
   If j = 1 Then Cells(ListBox1.List(0, 0), 1).Select
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

Private Sub TextBox1_Change()
    ListBox1.Clear
    
    Dim iText$, iAddress$, iCount&, iList As Worksheet, iCell As Range
    iText = TextBox1.Value
    
    If iText <> "" Then 'If Len(iText) > 0
       For Each iList In ThisWorkbook.Worksheets
           Set iCell = iList.UsedRange.Find(iText, , xlValues, xlPart)
           If Not iCell Is Nothing Then
              iAddress = iCell.Address
              Do
                   ListBox1.AddItem
                   ListBox1.List(iCount, 0) = iCell.Value
                   ListBox1.List(iCount, 1) = iCell.Address(, , , True)
                   iCount = iCount + 1
              Loop While iCell.Address <> iAddress
           End If
       Next
    End If
End Sub
 
Private Sub ListBox1_Click()
    If ListBox1.ListIndex > -1 Then
       Application.Goto Application.Range(ListBox1.List(ListBox1.ListIndex, 1))
    End If
End Sub

0

Как быстро найти значение на нескольких листах или в книгах?

Вы когда-нибудь задумывались о поиске определенного значения на нескольких листах или книгах в Excel? В этом руководстве представлены различные методы решения проблем, связанных с поиском на нескольких листах или поиском в нескольких книгах.

Поиск значения на нескольких листах книги с помощью функции поиска и замены

Искать значение во всех книгах папки с VBA

Быстрый поиск значения в нескольких открытых книгах с помощью Kutools for Excel

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

1. Выберите несколько вкладок листов, на которых вы хотите найти значение, удерживая Ctrl и щелкнув листы в Панель вкладок листа по одному. Смотрите скриншот:

2. Затем нажмите Ctrl + F для Найти и заменить окна и введите значение, которое вы хотите найти, в Найти то, что текстовое поле под Найти Вкладка, а затем нажмите кнопку Найти все кнопку, чтобы просмотреть все результаты. Смотрите скриншот:

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

1. Включите новую книгу и выберите ячейку, затем нажмите Alt + F11 ключи для открытия Microsoft Visual для базовых приложений окно.

2. Нажмите Вставить > Модули и вставьте ниже VBA в новое окно модуля.

VBA: поиск значения во всех книгах папки.

Sub SearchFolders()
'UpdatebyKutoolsforExcel20200913
    Dim xFso As Object
    Dim xFld As Object
    Dim xStrSearch As String
    Dim xStrPath As String
    Dim xStrFile As String
    Dim xOut As Worksheet
    Dim xWb As Workbook
    Dim xWk As Worksheet
    Dim xRow As Long
    Dim xFound As Range
    Dim xStrAddress As String
    Dim xFileDialog As FileDialog
    Dim xUpdate As Boolean
    Dim xCount As Long
    Dim xAWB As Workbook
    Dim xAWBStrPath As String
    Dim xBol As Boolean
    Set xAWB = ActiveWorkbook
    xAWBStrPath = xAWB.Path & "" & xAWB.Name
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a forlder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    xStrSearch = "KTE"
    xUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set xOut = Worksheets.Add
    xRow = 1
    With xOut
        .Cells(xRow, 1) = "Workbook"
        .Cells(xRow, 2) = "Worksheet"
        .Cells(xRow, 3) = "Cell"
        .Cells(xRow, 4) = "Text in Cell"
        Set xFso = CreateObject("Scripting.FileSystemObject")
        Set xFld = xFso.GetFolder(xStrPath)
        xStrFile = Dir(xStrPath & "*.xls*")
        Do While xStrFile <> ""
            xBol = False
            If (xStrPath & "" & xStrFile) = xAWBStrPath Then
                xBol = True
                Set xWb = xAWB
            Else
                Set xWb = Workbooks.Open(Filename:=xStrPath & "" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
            End If
            For Each xWk In xWb.Worksheets
                If xBol And (xWk.Name = .Name) Then
                Else
                Set xFound = xWk.UsedRange.Find(xStrSearch)
                If Not xFound Is Nothing Then
                    xStrAddress = xFound.Address
                End If
                Do
                    If xFound Is Nothing Then
                        Exit Do
                    Else
                        xCount = xCount + 1
                        xRow = xRow + 1
                        .Cells(xRow, 1) = xWb.Name
                        .Cells(xRow, 2) = xWk.Name
                        .Cells(xRow, 3) = xFound.Address
                        .Cells(xRow, 4) = xFound.Value
                    End If
                    Set xFound = xWk.Cells.FindNext(After:=xFound)
                Loop While xStrAddress <> xFound.Address
                End If
            Next
            If Not xBol Then
            xWb.Close (False)
            End If
            xStrFile = Dir
        Loop
        .Columns("A:D").EntireColumn.AutoFit
    End With
    MsgBox xCount & " cells have been found", , "Kutools for Excel"
ExitHandler:
    Set xOut = Nothing
    Set xWk = Nothing
    Set xWb = Nothing
    Set xFld = Nothing
    Set xFso = Nothing
    Application.ScreenUpdating = xUpdate
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

3. Затем нажмите F5 ключа или Run кнопку для выполнения этого VBA и Выберите папку Появится диалоговое окно, напоминающее вам о выборе папки, в которой вы хотите искать значение. Смотрите скриншот:

4. Затем щелкните OK и другое диалоговое окно появляется, чтобы напомнить вам, сколько ячеек было найдено. Смотрите скриншот:

5. Нажмите OK в Закрыть его, и все найденные ячейки будут перечислены на текущем листе с соответствующей информацией.

Наконечник: В приведенном выше VBA вы ищете значение «КТЕ», и вы можете изменить «КТЕ» из этого xStrSearch = «КТЭ« на другое значение по мере необходимости.

Если вы просто хотите найти значение в нескольких открытых книгах, вы можете использовать Kutools for Excel»продвинутый Найти и заменить утилита.

После бесплатная установка Kutools for Excel, пожалуйста, сделайте следующее:

1. В одной из открытых книг щелкните Кутулс > Навигация, а затем нажмите Найти и заменить кнопка  идти на Найти и заменить панель. Смотрите скриншот:

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

Наконечник:

Работы С Нами Kutools for Excelпродвинутый Найти и заменить Утилита, вы можете искать и заменять значения на выбранных листах в нескольких книгах, во всех книгах, активной книге, активном листе или выборе.

Относительные статьи:

• Как быстро найти и заменить на нескольких листах или во всей книге?
• Как быстро найти и заменить в нескольких открытых файлах Excel?
• Как найти наибольшее отрицательное значение (меньше 0) в Excel?
• Как извлечь все дубликаты из столбца в Excel?

Поиск какого-либо значения в ячейках Excel довольно часто встречающаяся задача при программировании какого-либо макроса. Решить ее можно разными способами. Однако, в разных ситуациях использование того или иного способа может быть не оправданным. В данной статье я рассмотрю 2 наиболее распространенных способа.

Поиск перебором значений

Довольно простой в реализации способ. Например, найти в колонке «A» ячейку, содержащую «123» можно примерно так:

Sheets("Данные").Select
For y = 1 To Cells.SpecialCells(xlLastCell).Row
    If Cells(y, 1) = "123" Then
        Exit For
    End If
Next y
MsgBox "Нашел в строке: " + CStr(y)

Минусами этого так сказать «классического» способа являются: медленная работа и громоздкость. А плюсом является его гибкость, т.к. таким способом можно реализовать сколь угодно сложные варианты поиска с различными вычислениями и т.п.

Поиск функцией Find

Гораздо быстрее обычного перебора и при этом довольно гибкий. В простейшем случае, чтобы найти в колонке A ячейку, содержащую «123» достаточно такого кода:

Sheets("Данные").Select
Set fcell = Columns("A:A").Find("123")
If Not fcell Is Nothing Then
    MsgBox "Нашел в строке: " + CStr(fcell.Row)
End If

Вкратце опишу что делают строчки данного кода:
1-я строка: Выбираем в книге лист «Данные»;
2-я строка: Осуществляем поиск значения «123» в колонке «A», результат поиска будет в fcell;
3-я строка: Если удалось найти значение, то fcell будет содержать Range-объект, в противном случае — будет пустой, т.е. Nothing.

Полностью синтаксис оператора поиска выглядит так:

Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)

What — Строка с текстом, который ищем или любой другой тип данных Excel

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

LookIn — Тип искомых данных. Может принимать одно из значений: xlFormulas (формулы), xlValues (значения), или xlNotes (примечания).

LookAt — Одно из значений: xlWhole (полное совпадение) или xlPart (частичное совпадение).

SearchOrder — Одно из значений: xlByRows (просматривать по строкам) или xlByColumns (просматривать по столбцам)

SearchDirection — Одно из значений: xlNext (поиск вперед) или xlPrevious (поиск назад)

MatchCase — Одно из значений: True (поиск чувствительный к регистру) или False (поиск без учета регистра)

MatchByte — Применяется при использовании мультибайтных кодировок: True (найденный мультибайтный символ должен соответствовать только мультибайтному символу) или False (найденный мультибайтный символ может соответствовать однобайтному символу)

SearchFormat — Используется вместе с FindFormat. Сначала задается значение FindFormat (например, для поиска ячеек с курсивным шрифтом так: Application.FindFormat.Font.Italic = True), а потом при использовании метода Find указываем параметр SearchFormat = True. Если при поиске не нужно учитывать формат ячеек, то нужно указать SearchFormat = False.

Чтобы продолжить поиск, можно использовать FindNext (искать «далее») или FindPrevious (искать «назад»).

Примеры поиска функцией Find

Пример 1: Найти в диапазоне «A1:A50» все ячейки с текстом «asd» и поменять их все на «qwe»

With Worksheets(1).Range("A1:A50")
  Set c = .Find("asd", LookIn:=xlValues)
  Do While Not c Is Nothing
    c.Value = "qwe"
    Set c = .FindNext(c)
  Loop
End With

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

Пример 2: Правильный поиск значения с использованием FindNext, не приводящий к зацикливанию.

With Worksheets(1).Range("A1:A50")
  Set c = .Find("asd", lookin:=xlValues)
  If Not c Is Nothing Then
    firstResult = c.Address
    Do
      c.Font.Bold = True
      Set c = .FindNext(c)
      If c Is Nothing Then Exit Do
    Loop While c.Address <> firstResult
  End If
End With

В ниже следующем примере используется другой вариант продолжения поиска — с помощью той же функции Find с параметром After. Когда найдена очередная ячейка, следующий поиск будет осуществляться уже после нее. Однако, как и с FindNext, когда будет достигнут конец диапазона, Find продолжит поиск с его начала, поэтому, чтобы не произошло зацикливания, необходимо проверять совпадение с первым результатом поиска.

Пример 3: Продолжение поиска с использованием Find с параметром After.

With Worksheets(1).Range("A1:A50")
  Set c = .Find("asd", lookin:=xlValues)
  If Not c Is Nothing Then
    firstResult = c.Address
    Do
      c.Font.Bold = True
      Set c = .Find("asd", After:=c, lookin:=xlValues)
      If c Is Nothing Then Exit Do
    Loop While c.Address <> firstResult
  End If
End With

Следующий пример демонстрирует применение SearchFormat для поиска по формату ячейки. Для указания формата необходимо задать свойство FindFormat.

Пример 4: Найти все ячейки с шрифтом «курсив» и поменять их формат на обычный (не «курсив»)

lLastRow = Cells.SpecialCells(xlLastCell).Row
lLastCol = Cells.SpecialCells(xlLastCell).Column
Application.FindFormat.Font.Italic = True
With Worksheets(1).Range(Cells(1, 1), Cells(lLastRow, lLastCol))
  Set c = .Find("", SearchFormat:=True)
  Do While Not c Is Nothing
    c.Font.Italic = False
    Set c = .Find("", After:=c, SearchFormat:=True)
  Loop
End With

Примечание: В данном примере намеренно не используется FindNext для поиска следующей ячейки, т.к. он не учитывает формат (статья об этом: https://support.microsoft.com/ru-ru/kb/282151)

Коротко опишу алгоритм поиска Примера 4. Первые две строки определяют последнюю строку (lLastRow) на листе и последний столбец (lLastCol). 3-я строка задает формат поиска, в данном случае, будем искать ячейки с шрифтом Italic. 4-я строка определяет область ячеек с которой будет работать программа (с ячейки A1 и до последней строки и последнего столбца). 5-я строка осуществляет поиск с использованием SearchFormat. 6-я строка — цикл пока результат поиска не будет пустым. 7-я строка — меняем шрифт на обычный (не курсив), 8-я строка продолжаем поиск после найденной ячейки.

Хочу обратить внимание на то, что в этом примере я не стал использовать «защиту от зацикливания», как в Примерах 2 и 3, т.к. шрифт меняется и после «прохождения» по всем ячейкам, больше не останется ни одной ячейки с курсивом.

Свойство FindFormat можно задавать разными способами, например, так:

With Application.FindFormat.Font 
  .Name = "Arial" 
  .FontStyle = "Regular" 
  .Size = 10 
End With

Поиск последней заполненной ячейки с помощью Find

Следующий пример — применение функции Find для поиска последней ячейки с заполненными данными. Использованные в Примере 4 SpecialCells находит последнюю ячейку даже если она не содержит ничего, но отформатирована или в ней раньше были данные, но были удалены.

Пример 5: Найти последнюю колонку и столбец, заполненные данными

Set c = Worksheets(1).UsedRange.Find("*", SearchDirection:=xlPrevious)
If Not c Is Nothing Then
  lLastRow = c.Row: lLastCol = c.Column 
Else
  lLastRow = 1: lLastCol = 1
End If
MsgBox "lLastRow=" & lLastRow & " lLastCol=" & lLastCol

В этом примере используется UsedRange, который так же как и SpecialCells возвращает все используемые ячейки, в т.ч. и те, что были использованы ранее, а сейчас пустые. Функция Find ищет ячейку с любым значением с конца диапазона.

Поиск по шаблону (маске)

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

Пример 6: Выделить красным шрифтом ячейки, в которых текст начинается со слова из 4-х букв, первая и последняя буквы «т», при этом после этого слова может следовать любой текст.

With Worksheets(1).Cells
  Set c = .Find("т??т*", LookIn:=xlValues, LookAt:=xlWhole)
  If Not c Is Nothing Then
    firstResult = c.Address
    Do
      c.Font.Color = RGB(255, 0, 0)
      Set c = .FindNext(c)
      If c Is Nothing Then Exit Do
    Loop While c.Address <> firstResult
  End If
End With

Для поиска функцией Find по маске (шаблону) можно применять символы:
* — для обозначения любого количества любых символов;
? — для обозначения одного любого символа;
~ — для обозначения символов *, ? и ~. (т.е. чтобы искать в тексте вопросительный знак, нужно написать ~?, чтобы искать именно звездочку (*), нужно написать ~* и наконец, чтобы найти в тексте тильду, необходимо написать ~~)

Поиск в скрытых строках и столбцах

Для поиска в скрытых ячейках нужно учитывать лишь один нюанс: поиск нужно осуществлять в формулах, а не в значениях, т.е. нужно использовать LookIn:=xlFormulas

Поиск даты с помощью Find

Если необходимо найти текущую дату или какую-то другую дату на листе Excel или в диапазоне с помощью Find, необходимо учитывать несколько нюансов:

• Тип данных Date в VBA представляется в виде #[месяц]/[день]/[год]#, соответственно, если необходимо найти фиксированную дату, например, 01 марта 2018 года, необходимо искать #3/1/2018#, а не «01.03.2018»
• В зависимости от формата ячеек, дата может выглядеть по-разному, поэтому, чтобы искать дату независимо от формата, поиск нужно делать не в значениях, а в формулах, т.е. использовать LookIn:=xlFormulas

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

Пример 7: Найти текущую дату на листе независимо от формата отображения даты.

d = Date
Set c = Cells.Find(d, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not c Is Nothing Then
  MsgBox "Нашел"
Else
  MsgBox "Не нашел"
End If

Пример 8: Найти 1 марта 2018 г.

d = #3/1/2018#
Set c = Cells.Find(d, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not c Is Nothing Then
  MsgBox "Нашел"
Else
  MsgBox "Не нашел"
End If

Искать часть даты — сложнее. Например, чтобы найти все ячейки, где месяц «март», недостаточно искать «03» или «3». Не работает с датами так же и поиск по шаблону. Единственный вариант, который я нашел — это выбрать формат в котором месяц прописью для ячеек с датами и искать слово «март» в xlValues.

Тем не менее, можно найти, например, 1 марта независимо от года.

Пример 9: Найти 1 марта любого года.

d = #3/1/1900#
Set c = Cells.Find(Format(d, "m/d/"), LookIn:=xlFormulas, LookAt:=xlPart)
If Not c Is Nothing Then
  MsgBox "Нашел"
Else
  MsgBox "Не нашел"
End If

в данный момент у меня код модуля вот такой  

  Option Explicit  

  Sub Поиск()  
Dim iFoundRng As Range  
Dim iSheet As Worksheet  
Dim iFoundSht As Worksheet  
Dim FirstAddress As String  
Dim TextToFind As Variant  
Dim iLastRow As Long  
Dim iShtName As String  

         Set iFoundSht = Sheets(«Поиск») ‘лист «Поиск» присваиваем переменной  
   iFoundSht.Range(«A5:AA5000»).Clear ‘очищаем диапазон ячеек на листе Поиск  
   ‘TextToFind = Application.InputBox(«Введите строку для поиска» & Chr(13) & Chr(13) & «Например: Lexus или Lexus 350», «Поиск», «Lexus 350»)  
   TextToFind = iFoundSht.Range(«B2»)  
   If TextToFind = «» Or TextToFind = False Then Exit Sub ‘если ничего не ввели — Выход!  
   TextToFind = Trim(TextToFind) ‘убираем начальные и конечные пробелы  
   Application.ScreenUpdating = False ‘отключаем обновление экрана  
   For Each iSheet In ThisWorkbook.Worksheets ‘поиск по листам  
       If iSheet.Name <> iFoundSht.Name Then  
           If iSheet.FilterMode = True Then iSheet.ShowAllData ‘если на листе установлен автофильтр, то снимаем его  
           Set iFoundRng = iSheet.Cells.Find(TextToFind, , xlFormulas, xlPart)  
           If Not iFoundRng Is Nothing Then ‘если нашли  
               FirstAddress = iFoundRng.Address ‘запоминаем адрес найденной ячейки, чтобы продолжить поиск по листу  
               Do  
                   With iFoundSht  
                       iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ‘определяем последнюю заполненную строку на листе поиск  
                       If iLastRow = 1 Then iLastRow = 4 ‘если лист пуст, то вставлять будем начиная с 7-й строки  
                       If iShtName <> iSheet.Name Then ‘если новый прайс-лист  
                           With .Cells(iLastRow + 1, 1) ‘проставляем имя листа  
                               .Value = «Лист: » & iSheet.Name & » Ячейка: » & iFoundRng.Address(0, 0)  
                               ‘добавляем гиперссылку  
                               iFoundSht.Hyperlinks.Add Anchor:=iFoundSht.Cells(iLastRow + 1, 1), Address:=»», _  
                                   SubAddress:=»‘» & iSheet.Name & «‘» & «!» & iFoundRng.Address, ScreenTip:=»Перейти на лист » & iSheet.Name  
                               ‘.Font.Bold = True ‘выделяем жирным  
                           End With  
                       End If  
                       ‘iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) ‘копируем всю строку  
                       iShtName = iSheet.Name ‘запоминаем имя листа  
                   End With  
                   Set iFoundRng = iSheet.Cells.FindNext(iFoundRng) ‘продолжаем поиск на том же листе  
               Loop While iFoundRng.Address <> FirstAddress  
           End If  
       End If  
   Next iSheet  
   Application.ScreenUpdating = True ‘включаем обновление экрана  
   MsgBox «Поиск завершён!», 64, «Поиск»  
End Sub  

  Sub Finder()  
Dim iRng As Range, TextForFind As String, FirstAddress As String, n As Integer, iLastRow As Long  
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row  
Range(Cells(5, 1), Cells(iLastRow + 1, 2)).Clear  
iLastRow = 4  
   TextForFind = InputBox(«Введите искомое слово (значение)», » Запрос для поиска»)  
   If TextForFind = «» Then  
       MsgBox «Вы ничего не указали», 48, «Вы чё, в натуре?»  
       Exit Sub  
   End If  

     For n = 2 To Sheets.Count  
       With Sheets(n).UsedRange  
           Set iRng = .Find(What:=TextForFind, LookIn:=xlFormulas, LookAt:=xlPart)  
           If Not iRng Is Nothing Then  
               FirstAddress = iRng.Address  
               Do  
                   Cells(iLastRow + 1, 1) = Sheets(n).Name  
                   Cells(iLastRow + 1, 2) = iRng.Address(0, 0)  
                   iLastRow = iLastRow + 1  
                   Set iRng = .FindNext(iRng)  
               Loop While iRng.Address <> FirstAddress  
           Else  
               MsgBox «Значение » & TextForFind & » не найдено!», 48, «Ошибка»  
           End If  
       End With  
   Next  
End Sub  

  по вашим словам я могу оставить только последнюю часть данного кода?

В данном примере предоставлен код 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».