Sub Macros2()
Application.DisplayAlerts = False
On Error GoTo MsgErr
 Dim iLastRow As Long
 Dim j As Long
 Dim i As Long
 Dim LastRowReport As Long
 'Dim ТекстДляПоиска As Long
 ТекстДляПоиска = LCase(Trim(Me.TextBox1.Text))
 iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
 Range(Cells(3, 1), Cells(iLastRow + 1, 24)).ClearContents
 iLastRow = 2
    For j = 1 To Sheets.Count - 1
        With Sheets(j)
            LastRowReport = .Cells(Rows.Count, 2).End(xlUp).Row
            For i = 1 To LastRowReport
                'If LCase(Trim(.Cells(i, 2).Value)) = ТекстДляПоиска Then
                If LCase(Trim(.Cells(i, 2).Value)) Like ТекстДляПоиска Then
                    Range(Cells(iLastRow + 1, 1), Cells(iLastRow + 1, 23)).Value = Range(.Cells(i, 1), .Cells(i, 23)).Value
                    iLastRow = iLastRow + 1
            End If
            Next
        End With
    Next
Application.DisplayAlerts = True
MsgBox "Данные выгружены! Если данных нет, проверте корректность введенных данных", vbExclamation + vbOKOnly
Exit Sub
MsgBox "Данные выгружены!", vbExclamation + vbOKOnly
MsgErr:
    MsgBox "Что-то пошло не так! Проверте данные", vbExclamation + vbOKOnly
    Application.DisplayAlerts = True
End Sub

Sub Macros2()
Application.DisplayAlerts = False
On Error GoTo MsgErr
 Dim iLastRow As Long
 Dim j As Long
 Dim i As Long
 Dim LastRowReport As Long
 Dim ТекстДляПоиска As Long
 ТекстДляПоиска = LCase(Trim(Me.TextBox1.Text))
 iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
 Range(Cells(3, 1), Cells(iLastRow + 1, 24)).ClearContents
 iLastRow = 2
    For j = 1 To Sheets.Count - 1
        With Sheets(j)
            LastRowReport = .Cells(Rows.Count, 2).End(xlUp).Row
            For i = 1 To LastRowReport
                If LCase(Trim(.Cells(i, 2).Value)) = ТекстДляПоиска Then
                    Range(Cells(iLastRow + 1, 1), Cells(iLastRow + 1, 23)).Value = Range(.Cells(i, 1), .Cells(i, 23)).Value
                    Cells(iLastRow + 1, 24) = Sheets(j).Name
                    iLastRow = iLastRow + 1
            End If
            Next
        End With
    Next
Application.DisplayAlerts = True
MsgBox "Данные выгружены! Если данных нет, проверте корректность введенных данных", vbExclamation + vbOKOnly
Exit Sub
MsgBox "Данные выгружены!", vbExclamation + vbOKOnly
MsgErr:
    MsgBox "Что-то пошло не так! Проверте данные", vbExclamation + vbOKOnly
    Application.DisplayAlerts = True
End Sub

Private Sub CommandButton1_Click()
Dim iLastRow As Long 'Переменная для номера последней строки отчета
Dim j As Long 'Переменная-счётчик для цикла
Dim i As Long 'Переменная-счётчик для другого цикла
 'Dim ТекстДляПоиска As Long 'если поиск по первому столбцу
Dim LastRowReport As Long 'Переменная для номера последней строки на листах
  'изначально перепутаны имена переменных - их нужно бы поменять местами :-) Но пусть уж так остаётся
 ТекстДляПоиска = Me.TextBox1.Text    ' читаем ТЕКСТ ДЛЯ ПОИСКА из поля TextBox1
 iLastRow = Cells(Rows.Count, 2).End(xlUp).Row 'Нашли номер последней строки отчета
 Range(Cells(2, 1), Cells(iLastRow + 1, 4)).ClearContents 'Очистили диапазон ниже заголовка
 iLastRow = 2 'Явно указываем, что последняя строка в отчете равна 2.
    For j = 1 To Sheets.Count - 1 'Начали цикл с первого по предпоследний лист
        With Sheets(j) 'Применительно к текущему листу
            LastRowReport = .Cells(Rows.Count, 2).End(xlUp).Row 'Узнали номер последней строки
            For i = 1 To LastRowReport 'Начали цикл на листе со второй строки по последнюю
                If .Cells(i, 3).Value = ТекстДляПоиска Then 'Если ячейка текущей строки в 1 столбце = ТЕКСТ ДЛЯ ПОИСКА из поля TextBox1, то
                    Range(Cells(iLastRow, 1), Cells(iLastRow, 4)).Value = Range(.Cells(i, 1), .Cells(i, 4)).Value 'диапазон ячеек в первой свободной строке отчета (столбцы 2:6) приравниваем аналогичному диапазону на исходном листе
                    'Cells(iLastRow + 1, 24) = Sheets(j).Name 'в седьмую ячейку заносим имя листа
                    iLastRow = iLastRow + 1 'увеличиваем на единичку номе последней строки (одну ведь мы уже заняли)
            End If 'конец проверки
            Next 'переход к следующей строке на текущем листе-исходнике
        End With 'конец работы с листом
    Next 'переход к следующему листу
MsgBox "Данные выгружены!", vbExclamation + vbOKOnly
End Sub

Select t.[1], t.[2], t.[3], t.[4], t.[5], t.[6], t.[7], t.[8], t.[9], t.[10], t.[11], t.[12], t.[13], t.[14], t.[15], t.[16], t.[17], t.[18], t.[19], t.[20], t.[21], t.[22] From (Select [1], [2], [3], [4], [5], [6], [7], [8], [9], [10], [11], [12], [13], [14], [15], [16], [17], [18], [19], [20], [21], [22] From [1$] Union All Select [1], [2], [3], [4], [5], [6], [7], [8], [9], [10], [11], [12], [13], [14], [15], [16], [17], [18], [19], [20], [21], [22] From [2$] Union All Select [1], [2], [3], [4], [5], [6], [7], [8], [9], [10], [11], [12], [13], [14], [15], [16], [17], [18], [19], [20], [21], [22] From [3$] Union All Select [1], [2], [3], [4], [5], [6], [7], [8], [9], [10], [11], [12], [13], [14], [15], [16], [17], [18], [19], [20], [21], [22] From [4$]) t Where t.[5] = ?

function RusToURL(txt as string) as string
dim i as long, l as string, t as string
  For i = 1 To Len(txt)
    l = Mid$(txt, i, 1)
    Select Case AscW(l)
        Case Is > 256: t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
        Case 32: t = "+"
        Case Else: t = l
    End Select
  RusToURL = RusToURL & t
  Next
end function

strQuery = "https://maps.googleapis.com/maps/api/geocode/xml?latlng=59.86,30.49&language=ru"
strQuery = strQuery & "address=" & strAddress  
strQuery = strQuery & "&sensor=false"

strQuery = "https://maps.googleapis.com/maps/api/geocode/xml?&language=ru"
strQuery = strQuery & "address=" & strAddress  
strQuery = strQuery & "&sensor=false"

strQuery = "https://maps.googleapis.com/maps/api/geocode/xml?"
strQuery = strQuery & "address=" & strAddress  
strQuery = strQuery & "&sensor=false"
strQuery = strQuery & "&language=ru"

Function MyGeocode(address As String) As String 
  Dim strAddress As String 
  Dim strQuery As String 
  Dim strLatitude As String 
  Dim strLongitude As String 
  strAddress = URLEncode(address) 
  'Assemble the query string 
  strQuery = "http://maps.googleapis.com/maps/api/geocode/xml?" 
  strQuery = strQuery & "address=" & strAddress  
  strQuery = strQuery & "&sensor=false" 
  'define XML and HTTP components 
  Dim googleResult As New MSXML2.DOMDocument 
  Dim googleService As New MSXML2.XMLHTTP 
  Dim oNodes As MSXML2.IXMLDOMNodeList 
  Dim oNode As MSXML2.IXMLDOMNode 
  'create HTTP request to query URL - make sure to have 
  'that last "False" there for synchronous operation 
  googleService.Open "GET", strQuery, False 
  googleService.send 
  googleResult.LoadXML (googleService.responseText) 
  Set oNodes = googleResult.getElementsByTagName("geometry") 
  If oNodes.Length = 1 Then 
    For Each oNode In oNodes 
      strLatitude = oNode.ChildNodes(0).ChildNodes(0).Text 
      strLongitude = oNode.ChildNodes(0).ChildNodes(1).Text 
      MyGeocode = strLatitude & "," & strLongitude 
    Next oNode 
  Else 
    MyGeocode = "Not Found (try again, you may have done too many too fast)" 
  End If 
End Function
 
Public Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String 
  Dim StringLen As Long: StringLen = Len(StringVal) 
  If StringLen>0 Then 
    ReDim result(StringLen) As String 
    Dim i As Long, CharCode As Integer 
    Dim Char As String, Space As String 
    If SpaceAsPlus Then Space = "+" Else Space = "%20" 
    For i = 1 To StringLen 
      Char = Mid$(StringVal, i, 1)   
      CharCode = Asc(Char) 
      Select Case CharCode 
      Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126 
        result(i) = Char 
      Case 32 
        result(i) = Space 
      Case 0 To 15 
        result(i) = "%0" & Hex(CharCode) 
      Case Else 
        result(i) = "%" & Hex(CharCode) 
      End Select 
    Next i 
    URLEncode = Join(result, "") 
  End If 
End Function 

Sub Кнопка3_Щелчок()
Application.ScreenUpdating = False
With Sheets("Данные")
    .Visible = xlSheetVisible
Worksheets("Данные").Select
Lr = 2
While Cells(Lr, 1) <> ""
Lr = Lr + 1
Wend
    Dim sourceRange As Range
    Dim destrange As Range
    'Lr = LastRow_1(Sheets(2)) + 1
    Set sourceRange = Worksheets("Данные").Range("a1:u" & Lr)
    Set destrange = Worksheets("Для Алексея").Range("a2")
    sourceRange.Copy destrange
    Worksheets("Для Алексея").Select
    .Visible = xlSheetVeryHidden
End With
Application.ScreenUpdating = True
End Sub