---

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Dim FSO As Object
Dim FileFound As Boolean
Dim CurrentFileName As String
Dim CurrentFilePath As String
Dim CurrentFileLocation As String

Dim GlobalCurrentCount As Long
Dim GlobalTotalCount As Long

Sub SmartBatchPrint()
    Dim MainFolderPath As String
    Dim Cell As Range
    Dim TargetNumber As String
    Dim Suffix As String
    Dim AllowPrint As Boolean
    
    ' Динамический массив для путей
    Dim SearchPaths() As String
    Dim PathIndex As Long
    
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim TimeLeft As Double
    
    ' Переменные для поиска листов по содержимому
    Dim Keywords(1 To 5) As String
    Dim KeywordFound(1 To 5) As Boolean
    Dim i As Long
    Dim SheetsPrintedCount As Long
    Dim FoundCell As Range
    
    ' =========================================================================
    ' БЛОК НАСТРОЙКИ КЛЮЧЕВЫХ СЛОВ (Ищутся внутри текста ячеек)
    ' =========================================================================
    Keywords(1) = "ПРОТОКОЛ ИСПЫТАНИЙ"
    Keywords(2) = "ОКОНЧАНИЕ РАСЧЕТНО-СПРАВОЧНЫХ"
    Keywords(3) = "Приложение №1"
    Keywords(4) = "АКТ ИСПЫТАНИЙ"
    Keywords(5) = "ПЕРВИЧНЫЕ ЗАПИСИ"
    ' =========================================================================
    
    ' 1. Базовый путь к главной папке
    MainFolderPath = "C:\Users\vorob\OneDrive\Desktop\Печать\"
    
    ' Динамический массив для путей
    ReDim SearchPaths(1 To 1) ' Укажи здесь общее количество папок
    
    SearchPaths(1) = "X:\2025 год\14. Шум\"
    ' SearchPaths(1) = MainFolderPath & "ИП Якимов\Протоколы\"
    ' SearchPaths(2) = MainFolderPath & "УМВД\Протоколы\Печать\"
    ' SearchPaths(3) = MainFolderPath & "Ягодное\Протокол\Печать\"
    ' SearchPaths(4) = MainFolderPath & "Вятавтодор\"
    ' SearchPaths(5) = "X:\2025 год\01. Атмосфера\"
    
    Suffix = "ШУМ."
    AllowPrint = True
    
    ' Подсчет общего количества работы
    GlobalTotalCount = 0
    For Each Cell In Selection
        If Cell.Value <> "" And Cell.Interior.ColorIndex = xlNone Then
            GlobalTotalCount = GlobalTotalCount + 1
        End If
    Next Cell
    
    If GlobalTotalCount = 0 Then Exit Sub
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    GlobalCurrentCount = 0
    For Each Cell In Selection
        
        DoEvents
        Application.EnableCancelKey = xlErrorHandler
        On Error GoTo StrictEmergencyStop
        
        If Cell.Value <> "" Then
            If Cell.Interior.ColorIndex <> xlNone Then GoTo SkipCell
            
            GlobalCurrentCount = GlobalCurrentCount + 1
            TargetNumber = Trim(CStr(Cell.Value)) & Suffix
            
            ' Сброс переменных перед поиском нового файла
            FileFound = False
            CurrentFileName = ""
            CurrentFilePath = ""
            CurrentFileLocation = ""
            
            Application.StatusBar = "Старт поиска: " & TargetNumber & "... (" & GlobalCurrentCount & "/" & GlobalTotalCount & ")"
            DoEvents
            
            ' АВТОМАТИЧЕСКИЙ ОБХОД ВСЕХ ПАПОК ИЗ СПИСКА
            For PathIndex = LBound(SearchPaths) To UBound(SearchPaths)
                If Not FileFound Then
                    If FSO.FolderExists(SearchPaths(PathIndex)) Then
                        Call FastSubFolderSearch(SearchPaths(PathIndex), TargetNumber, MainFolderPath)
                    End If
                Else
                    Exit For
                End If
            Next PathIndex
            
            ' Отрисовка результатов поиска
            Application.ScreenUpdating = True
            DoEvents
            
            If FileFound Then
                ' По умолчанию красим в стандартный зеленый
                Cell.Interior.Color = RGB(198, 239, 206)
                
                For TimeLeft = 3# To 0# Step -0.05
                    Application.StatusBar = "Найдено: " & CurrentFileName & " -> Сканирование содержимого листов... (" & Format(TimeLeft, "0.00") & " сек)"
                    DoEvents
                    Sleep 50
                Next TimeLeft
                
                ' Проверка разрешения на печать
                If AllowPrint Then
                    Application.ScreenUpdating = False
                    Set WB = Workbooks.Open(Filename:=CurrentFilePath, UpdateLinks:=0, ReadOnly:=True)
                    
                    ' Сброс флагов найденных ключевых слов для нового файла
                    SheetsPrintedCount = 0
                    For i = 1 To 5
                        KeywordFound(i) = False
                    Next i
                    
                    ' Перебор ключевых слов по порядку приоритета (от 1 до 5)
                    For i = 1 To 5
                        For Each WS In WB.Worksheets
                            
                            ' Ищем ключевое слово ВНУТРИ ячеек листа (по частичному совпадению, без учета регистра)
                            Set FoundCell = Nothing
                            Set FoundCell = WS.Cells.Find(What:=Keywords(i), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
                            
                            ' Если фраза найдена в содержимом листа
                            If Not FoundCell Is Nothing Then
                                On Error Resume Next
                                WS.PrintOut
                                On Error GoTo 0
                                KeywordFound(i) = True
                                SheetsPrintedCount = SheetsPrintedCount + 1
                                Exit For ' Нашли лист, содержащий это слово, переходим к следующему ключевому слову
                            End If
                            
                        Next WS
                    Next i
                    
                    WB.Close SaveChanges:=False
                    
                    ' Если нашли и распечатали меньше 5 листов (какой-то текст не был найден)
                    If SheetsPrintedCount < 5 Then
                        Cell.Interior.Color = RGB(158, 213, 97) ' Светло-зеленый для неполного комплекта
                    End If
                Else
                    Application.StatusBar = "Найдено: " & CurrentFileName & " -> Печать пропущена (параметр AllowPrint = False)"
                    Cell.Interior.Color = RGB(226, 211, 120)
                    Sleep 2000
                End If
            Else
                ' Если файл НЕ найден
                Application.StatusBar = "Файл для " & TargetNumber & " НЕ НАЙДЕН! Переходим к следующему..."
                Cell.Interior.Color = RGB(255, 199, 206) ' Красный
                
                DoEvents
                Sleep 2000
                Application.ScreenUpdating = False
            End If
            
        End If
SkipCell:
    Next Cell

    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub

StrictEmergencyStop:
    Application.StatusBar = False
    DoEvents
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Процесс остановлен пользователем!", vbCritical, "Остановка"
End Sub

' Функция поиска
Sub FastSubFolderSearch(ByVal FolderPath As String, ByVal FileNumber As String, ByVal MainPath As String)
    Dim Folder As Object
    Dim SubFolder As Object
    Dim File As Object
    Dim FirstNumInName As String
    
    If FileFound Then Exit Sub
    
    Application.StatusBar = "Ищу " & FileNumber & " в: " & Right(FolderPath, 30) & "... (" & GlobalCurrentCount & "/" & GlobalTotalCount & ")"
    DoEvents
    
    Set Folder = FSO.GetFolder(FolderPath)
    
    For Each File In Folder.Files
        If InStr(1, File.Name, ".xlsx", vbTextCompare) > 0 Or InStr(1, File.Name, ".xls", vbTextCompare) > 0 Then
            FirstNumInName = Split(File.Name, " ")(0)
            
            If StrComp(FirstNumInName, FileNumber, vbTextCompare) = 0 Then
                FileFound = True
                CurrentFileName = File.Name
                CurrentFilePath = File.Path
                CurrentFileLocation = "\" & Replace(File.ParentFolder.Path & "\", MainPath, "", 1, -1, vbTextCompare)
                Exit Sub
            End If
        End If
    Next File
    
    For Each SubFolder In Folder.SubFolders
        If FileFound Then Exit Sub
        Call FastSubFolderSearch(SubFolder.Path & "\", FileNumber, MainPath)
    Next SubFolder
End Sub