---

#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