Range(Cells.Find("Кодовое слово"), Cells(Rows.Count, 7).End(xlUp)).Select

Sub CHECK_DATA()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim katal As Variant
Dim CompareRange As Variant, x As Variant, y As Variant
Dim n As Long
'Dim Ofrange As Long

Dim input_sheet As String
input_sheet = InputBox("введите период(название листа) для проверки")

   katal = GetFolderPath("Укажите каталог с файлами", ThisWorkbook.Path)
If katal <> "" Then
   Dim FS, KATALOG, FILE, MASSIV As Object
   Set FS = CreateObject("Scripting.FileSystemObject")
   Set KATALOG = FS.GetFolder(katal)
   Set MASSIV = KATALOG.Files
Range("B12").Select
    n = Empty
    Do While Range("B12").Offset(1 + n) <> Empty
    
    Range("B12").Offset(1 + n, 18).Value = Range("B12").Offset(1 + n).Value & " " & Range("B12").Offset(1 + n, 3).Value
    n = n + 1
    Loop
    
   Range("B12").Select
   Set Rng = Range(Selection, Selection.End(xlDown)).Offset(0, 18) ' выбираем в сводном файле диапазон КР+запчасть для сверки
   
  ' If Rng.Cells.Count > 20000 Then Exit Sub
 
For Each FILE In MASSIV   'пробегаемся по каждому файлу из папки
    Workbooks.Open Filename:=FILE
    On Error Resume Next
 If ActiveWorkbook.Name <> "файл1.xlsm" Then

     If Sheets(input_sheet) Is Nothing Then
     GoTo lastline
     Else
       Sheets(input_sheet).Activate
 
        Range("A1:C2000").Find("Код ЗЧ", LookIn:=xlValues).Select    'цикл поиска таблицы РТВ по привязке к коду ЗЧ
        If Selection Is Nothing Then
        GoTo lastline
        Else
        
        Set CompareRange = Range(Selection, Selection.End(xlDown))

        


         For Each x In Rng
         For Each y In CompareRange
        
         y.Offset(0, 9).Value = y.Value & " " & y.Offset(0, 3).Value
        
            If x.Value = y.Offset(0, 9).Value Then x.Offset(0, -18).Interior.Color = y.Interior.Color
         Next y
        Next x
        End If
      End If
  End If
lastline:
ActiveWorkbook.Close (False)


Next FILE

    MsgBox "Готово"
Columns("T:T").Delete

Else
    MsgBox "Каталог не выбран"
End If




Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
                     Optional ByVal InitialPath As String = "c:\", _
                     Optional ByVal FilterDescription As String = "Файлы Excel", _
                     Optional ByVal FilterExtention As String = "*.xlsm*") As String
    Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

Sub проверка_возврата()
Application.ScreenUpdating = False
Dim WB1 As Workbook, Wb2 As Workbook
Dim x As Integer
Dim wk16 As Worksheet
On Error Resume Next
Set Wb2 = Workbooks("\\Srv-f01\svodnyi.xlsm") ' таблица, в которую копируются контрольные ячейки
Set WB1 = Application.Workbooks.Open("\\Srv-f01\Public\file1.xlsm") ' файл с контрольной ячейкой
x = 2
For Each wk16 In WB1.Worksheets
    wk16.Cells(500, 87).Copy
    With Wb2.Sheets(1).Cells(9, x)
        .PasteSpecial Paste:=xlPasteAll

    End With
    x = x + 1
Next wk16
WB1.Close (False)
Application.ScreenUpdating = True
End Sub

For Each wsSh In ThisWorkbook.Worksheets  'пробегаемся по вкладкам
    With wsSh
        .Tab.ColorIndex = 4 ' красим ярлыки листов в зеленый
        With .Range("CI500")
            .Interior.ColorIndex = 4 ' красим зеленкой ячейку CI500
            .Value = wsSh.Name
        End With
     End With
Next