Public aaa()

    Dim fso As Object
    Dim fld As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim lRow As Long
    Dim rFound As Range
    Dim firstAddress As String
    Dim arrFiles() As Variant
    Dim fileCount As Integer
    Dim processedCount As Integer
    Dim startTime As Double
    Dim i As Long
    
    On Error GoTo ErrHandler
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' Запрашиваем путь к папке и текст для поиска
    strPath = InputBox("Введите путь к папке:", "Форма поиска", "C:\Users\Den\Downloads")
    If strPath = "" Then Exit Sub
    
    strSearch = InputBox("Введите текст для поиска:", "Форма поиска", "")
    If strSearch = "" Then Exit Sub
    
    ' Проверяем существование папки
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(strPath) Then
        MsgBox "Ошибка: Папка '" & strPath & "' не существует.", vbCritical
        Exit Sub
    End If
    
    Set fld = fso.GetFolder(strPath)
    
    ' Проверяем корректность объекта папки
    If fld Is Nothing Then
        MsgBox "Ошибка: Объект папки не создан.", vbCritical
        Exit Sub
    End If
    
    ' Альтернатива через Dir для надежности
    strFile = Dir(strPath & "\*.xls*")
    If strFile = "" Then
        MsgBox "Ошибка: В папке нет файлов Excel.", vbCritical
        Exit Sub
    End If
    
    ' Создаем новый лист для отчета
    Set wOut = Worksheets.Add
    lRow = 1
    
    With wOut
        .Cells(lRow, 1) = "Книга"
        .Cells(lRow, 2) = "Лист"
        .Cells(lRow, 3) = "Ячейка"
        .Cells(lRow, 4) = "Результат"
    End With
    
    ' Формируем массив файлов
    ReDim arrFiles(fld.Files.Count)
    i = 0
    While strFile <> ""
        arrFiles(i) = strPath & "\" & strFile
        i = i + 1
        strFile = Dir
    Wend
    
    ReDim Preserve arrFiles(i - 1)
    
    ' Начинаем обработку файлов
    startTime = Timer
    
    For processedCount = 0 To UBound(arrFiles)
        Set wbk = Workbooks.Open(FileName:=arrFiles(processedCount), UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
        
        For Each wks In wbk.Worksheets
            Set rFound = wks.UsedRange.Find(strSearch)
            
            If Not rFound Is Nothing Then
                firstAddress = rFound.Address
                Do
                    lRow = lRow + 1
                    wOut.Cells(lRow, 1) = wbk.Name
                    wOut.Cells(lRow, 2) = wks.Name
                    wOut.Cells(lRow, 3) = rFound.Address
                    wOut.Cells(lRow, 4) = rFound.Value
                    Set rFound = wks.UsedRange.FindNext(rFound)
                Loop While Not rFound Is Nothing And rFound.Address <> firstAddress
            End If
        Next
        
        wbk.Close SaveChanges:=False
    Next
    
    wOut.Columns("A:D").EntireColumn.AutoFit
    
    MsgBox "Поиск завершен. Время выполнения: " & Format(Timer - startTime, "#0.0 сек.")
    
ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub
    
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
    
End Sub

'Attribute VB_Name = "search_in_files"

Public Sub Поиск_во_всех_файлах()

Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String

On Error GoTo ErrHandler

Application.ScreenUpdating = False

strPath = "C:\ПОИСК" 'поменять на ваш путь
strSearch = InputBox("Поиск в папке C ПОИСК:", "Форма поиска", "")

If strSearch = "" Then
Exit Sub
End If

Set wOut = Worksheets.Add
lRow = 1

With wOut
.Cells(lRow, 1) = "Книга"
.Cells(lRow, 2) = "Лист"
.Cells(lRow, 3) = "Ячейка"
.Cells(lRow, 4) = "Результат"

Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
strFile = Dir(strPath & "\*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open(fileName:=strPath & "\" & strFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each wks In wbk.Worksheets
Set rFound = wks.UsedRange.Find(strSearch)
If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If

Do
If rFound Is Nothing Then
Exit Do

Else
lRow = lRow + 1
.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value
End If

Set rFound = wks.Cells.FindNext(After:=rFound)
Loop While strFirstAddress <> rFound.Address
Next
'wbk.Close (False)
strFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With

MsgBox "Все"
ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler

End Sub

Sub СохранитьИзмененияВоткрытыхКнигах()
    Dim booksToCheck() As Variant   ' Используем тип Variant для массива
    Dim activeWb As Workbook
    Dim targetPath As String
    Dim newFullPath As String
    Dim i As Integer
    
    Application.DisplayAlerts = False ' Убрать оповещение Microsoft Office, которое появляется при попытке удаления персональных данных или проверке конфиденциальной информации
    
   
    ' Список имен книг для проверки и сохранения
    booksToCheck = Array("Книга1.xls", "Книга2.xlsx", "Книга3.xlsx")
     
    ' Целевая папка для сохранения копий
    targetPath = "C:\Users\ВашПользователь\Documents\NovayaPapka"
    
    ' Проходим по списку книг
    For i = LBound(booksToCheck) To UBound(booksToCheck)
        Set activeWb = Nothing  ' Предварительно очищаем объект
        On Error Resume Next
        Set activeWb = Workbooks(CStr(booksToCheck(i)))
        On Error GoTo 0
        
        If Not activeWb Is Nothing Then
            ' Книга найдена, продолжаем работу
            activeWb.Activate
            
            ' Формируем полный путь для сохранения
            newFullPath = targetPath & "\" & activeWb.Name
            
            ' Проверяем существование папки
            If Len(Dir(targetPath, vbDirectory)) = 0 Then
                ' Папка не существует, пытаемся создать её
                On Error Resume Next
                MkDir targetPath
                
                If Err.Number <> 0 Then
                    MsgBox "Не удалось создать папку '" & targetPath & "'. Проверьте права доступа.", vbCritical
                    Err.Clear
                    On Error GoTo 0
                End If
                On Error GoTo 0
            End If
            
            ' Сохраняем книгу с изменениями в новую папку
            activeWb.SaveCopyAs fileName:=newFullPath
            
            'MsgBox "Изменённая книга '" & activeWb.Name & "' успешно сохранена в '" & newFullPath & "'!"
        Else
            ' Если книга не найдена, проверяем наличие старого файла и удаляем его
            newFullPath = targetPath & "\" & booksToCheck(i)
            
            If Len(Dir(newFullPath)) > 0 Then
                Kill newFullPath
                MsgBox "Файл '" & booksToCheck(i) & "' удалён, так как книга не была найдена.", vbInformation
            Else
                MsgBox "Книга с именем '" & booksToCheck(i) & "' не найдена, файл для удаления также отсутствует.", vbInformation
            End If
        End If
    Next i
End Sub

Sub CheckAndSaveMultipleBooks()
    Dim booksToCheck() As Variant   ' Используем тип Variant для массива
    Dim activeWb As Workbook
    Dim targetPath As String
    Dim newFullPath As String
    Dim i As Integer
    
    ' Список имен книг для проверки и сохранения
    booksToCheck = Array("Книга1.xls", "Книга2.xlsx", "Книга3.xlsx")
    
    ' Целевая папка для сохранения копий
    targetPath = "C:\Users\ВашПользователь\Documents\NovayaPapka"
    
    ' Проходим по списку книг
    For i = LBound(booksToCheck) To UBound(booksToCheck)
        On Error Resume Next
        Set activeWb = Workbooks(CStr(booksToCheck(i)))  ' Преобразование строки в нужный формат
        On Error GoTo 0
        
        If Not activeWb Is Nothing Then
            ' Перейти на найденную книгу
            activeWb.Activate
            
            ' Формируем полный путь для сохранения
            newFullPath = targetPath & "\" & activeWb.Name
            
            ' Проверяем существование папки
            If Dir(targetPath, vbDirectory) = "" Then
                MkDir targetPath
            End If
            
            ' Сохраняем книгу с изменениями в новую папку
            activeWb.SaveCopyAs Filename:=newFullPath
            
            'MsgBox "Изменённая книга '" & activeWb.Name & "' успешно сохранена в '" & newFullPath & "'!"
        Else
            MsgBox "Книга с именем '" & CStr(booksToCheck(i)) & "' не найдена.", vbInformation
        End If
    Next i
End Sub

Sub Copy_File22()
Dim Книга As Workbook 'Сохранить измененные файлы
Dim sFileName As String, sNewFileName As String 'Копировать файлы


'СохранениеВсехИзмененныхКниг2() 'Корректней сохраняет
    'Dim Книга As Workbook
    ' Проходим через каждую рабочую книгу в коллекции Workbooks
    For Each Книга In Workbooks
        ' Проверяем, имеет ли книга путь сохранения
        If Книга.Path <> "" Then
            ' Проверяем, была ли книга изменена
            ' с момента последнего сохранения
            If Not Книга.Saved Then
                ' Если книга была изменена, сохраняем ее
                Книга.Save
            End If
        End If
    Next Книга

    'Dim sFileName As String, sNewFileName As String
        sFileName = "C:\Users\***\Downloads\Книга1.xls"    'имя файла для копирования
    sNewFileName = "C:\Users\***\Downloads\!ПОИСК\Книга1.xls"    'имя копируемого файла.
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    FileCopy sFileName, sNewFileName 'копируем файл
End Sub

Sub Поиск_во_всех_файлах()
Dim iShtName$, iPath$, iFileName$, firstAddress$
Dim iSheet As Worksheet, iFoundSht As Worksheet
Dim iTempWB As Workbook, iBazaWB As Workbook
Dim TextToFind As Variant, iFoundRng As Range
Dim FD As FileDialog, iLastRow&
Dim FoundAny As Boolean

    TextToFind = Application.InputBox("Введите текст для поиска:", "Поиск")
    If TextToFind = "" Or TextToFind = False Then Exit Sub
    TextToFind = Trim(TextToFind)
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .AllowMultiSelect = False
        .Title = "Укажите любой файл в папке"
        .ButtonName = "Выбрать папку"
        If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), "\"))
    End With
    Set FD = Nothing
    Workbooks.Add
    Sheets.Add.Name = "Поиск"
    Set iFoundSht = ActiveSheet
    iFoundSht.Cells(1, 1) = "Ищем: " & TextToFind
    iFoundSht.Cells(1, 1).Font.Bold = True
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .StatusBar = "Идёт поиск..."
        .ShowWindowsInTaskbar = False
        iFileName = Dir(iPath & "*.xls")
        Do While iFileName$ <> ""
            Set iTempWB = Workbooks.Open(fileName:=iPath & iFileName, UpdateLinks:=False, ReadOnly:=True)
            For Each iSheet In iTempWB.Sheets
                If iSheet.FilterMode = True Then iSheet.ShowAllData
                Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
                If Not iFoundRng Is Nothing Then
                    FoundAny = True
                    firstAddress = iFoundRng.Address
                    Do
                        With iFoundSht
                            iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                            If iLastRow = 1 Then iLastRow = 2
                            If iShtName <> iSheet.Name Then    'если новый файл
                                With .Cells(iLastRow + 2, 1)
                                    .Value = "Файл: " & iTempWB.Name & ", Лист: " & 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
                Else
                End If
            Next
            iTempWB.Close SaveChanges:=False
            iFileName = Dir
        Loop
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    If FoundAny = False Then
        MsgBox "Текст '" & TextToFind & "' ни в одном из файлов в папке:" & Chr(10) & iPath & Chr(10) & " не был найден!", 48, "Отчёт"
        iFoundSht.Parent.Close SaveChanges:=False
        Exit Sub
    End If
    MsgBox "Поиск " & TextToFind & " завершён!", 64, "Поиск"
End Sub