Sub TOMAT2()
    Dim xlWb As Workbook
    Dim rng As Range
    Dim ishFile As String

    Range("A5:AA1000").ClearContents
    ishFile = ThisWorkbook.Path & Range("B3").Value
    Application.ScreenUpdating = False
    Set xlWb = Workbooks.Open(ishFile, , True)
    Set rng = xlWb.Worksheets("ucx").Range("A1:AA1000")
    
    rng.Copy Destination:=ThisWorkbook.Worksheets("Kyda").Range("A6")
    
    Set rng = Nothing
    xlWb.Close
    Set xlWb = Nothing
    Application.ScreenUpdating = True
End Sub

Sub mReferens()
    Dim ref As Object 'или  Reference но тогда нужно подключить "Microsoft Visual Basic for Applications Extensibility 5.3"
    Dim msg As String
    For Each ref In ActiveWorkbook.VBProject.References
        msg = msg & ref.Name & vbCrLf
        msg = msg & ref.Description & vbCrLf
        msg = msg & ref.fullpath & vbCrLf
    Next
    MsgBox msg
End Sub

Range("A5:AA1000").ClearContents

Range("A5:AA1000").Clear

xlWb.Close False

    Dim oble As OLEObject
    For Each oble In Sheets("Kyda").OLEObjects
        If TypeName(oble.Object) <> "CommandButton" Then oble.Delete
    Next

    rng.Copy
    ThisWorkbook.Worksheets("Kyda").Range("A6").PasteSpecial xlPasteValues
    ThisWorkbook.Worksheets("Kyda").Range("A6").PasteSpecial xlPasteFormats
    Application.CutCopyMode = False

xlWb.Close False
' rng.Copy False

Application.CutCopyMode = False

Set xlWb = Workbooks.Open(ishFile, False, True)

        
    '********  Этот шаг не получается
    Dim rngB As Range
    Set rngB = xlWb.Worksheets("ucx").Range("C:C")
    rng.Copy
    ThisWorkbook.Worksheets("Kyda").Range("C1").PasteSpecial xlPasteAll
    Set rngB = Nothing
    '*****  Этот шаг не получается

     
    rng.Copy
    ThisWorkbook.Worksheets("Kyda").Range("A1").PasteSpecial xlPasteValues
    ThisWorkbook.Worksheets("Kyda").Range("A1").PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
    '********
    Dim rngB As Range
    Set rngB = xlWb.Worksheets("ucx").Range("C:C")
    rngB.Copy
    ThisWorkbook.Worksheets("Kyda").Range("C1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False ' очистка буфера
    Set rngB = Nothing
    '********

    Set rng = Nothing
    xlWb.Close False
    Set xlWb = Nothing
    ThisWorkbook.Worksheets("Kyda").Range("A1").Select  ' т.к. после выполнения макроса вся таблица остается выделенной
    Application.ScreenUpdating = True
    mReferens
End Sub

    With Button
        .Caption = "Сохранить все книги"
        .Style = msoButtonIcon
        .OnAction = "SaveBook1" & "SaveBook2"  '  здесь ошибка
       ' .OnAction = "SaveBook1", "SaveBook2"  '  здесь ошибка
    End With

Sub temp()
    Application.Run "Module1.SaveBook1"
    Application.Run "Module1.SaveBook2"
End Sub

.OnAction "temp"

Sub TOMAT452()
    Dim xlWb As Workbook
    Dim rng As Range
    Dim ishFile As String
     Dim iKOT As Long
     Dim iOC As Long
     Dim iABT As Long
    Dim nSh As String
    Dim i As Long
    'для отмены мелькания на экране
    Application.ScreenUpdating = False
'    Sheets("452").Activate
    '********
    'берем название обрабатываемого листа с ячейки "B1" листа "A3" этой книги
    nSh = CStr(ThisWorkbook.Sheets("A3").Range("B1").Value)
    'берем название файла с ячейки "B1" листа "A3" _
    (т.к. мы установили в ячейке нужный формат и храним в значение только название без расширения то надо брать text)
    ishFile = ThisWorkbook.Path & ThisWorkbook.Sheets("A3").Range("B1").Text
    'проверка существования файла
    If Dir(ishFile, vbNormal) = "" Then
        MsgBox "Проверьте путь и файл"
        Exit Sub
    End If
    'открытие файла
    Set xlWb = Workbooks.Open(ishFile, False, True)
    ' поиск столбца "KOT"
    Set rng = xlWb.Worksheets(CStr(ThisWorkbook.Sheets("A3").Range("B1"))).Cells.Find( _
        "KOT", LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=True)
    If rng Is Nothing Then
        Set rng = Nothing
        xlWb.Close
        Set xlWb = Nothing
        MsgBox "Не найден столбец ""KOT""", vbCritical, "Проверка"
        Exit Sub
    Else
        iKOT = rng.Column
    End If
    ' поиск столбца "OC-H"
    Set rng = xlWb.Worksheets( 1 ).Cells.Find("OC-H", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
    If rng Is Nothing Then
        Set rng = Nothing
        xlWb.Close
        Set xlWb = Nothing
        MsgBox "Не найден столбец ""OC-H""", vbCritical, "Проверка"
        Exit Sub
    Else
        iOC = rng.Column
    End If
    ' поиск столбца "ABTO"
    Set rng = ThisWorkbook.Worksheets(nSh).Cells.Find("ABTO", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
    If rng Is Nothing Then
        Set rng = Nothing
        xlWb.Close
        Set xlWb = Nothing
        MsgBox "Не найден столбец ""ABTO""", vbCritical, "Проверка"
        Exit Sub
    Else
        iABT = rng.Column
    End If
    ' определяем нижнюю ячейку в столбце "OC-H"
    nisiOC = xlWb.Worksheets( 1 ).Cells(Rows.Count, iOC).End(xlUp).Row
    ' определяем нижнюю ячейку в столбце "ABTO"
    nisiABT = ThisWorkbook.Worksheets(nSh).Cells(Rows.Count, iABT).End(xlUp).Row
    '***************************************************
    For i =  2  To nisiOC 'делаем пробег по столбцу "iOC" со второй строки по "nisiOC"
        With ThisWorkbook.Worksheets(nSh)
            'проверка есть ли значение в столбце "KOT" и "iOC"
            If xlWb.Worksheets( 1 ).Cells(i, iOC) <> "" And _
                xlWb.Worksheets( 1 ).Cells(i, iKOT) <> "" Then
                ' ищем значение столбца "OC-H" в столбце "ABTO"
                Set rng = .Range(.Cells( 2 , iABT), .Cells(nisiABT, iABT)).Find( _
                    xlWb.Worksheets( 1 ).Cells(i, iOC), _
                    LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=True)
                'проверка найдено ли значение
                If Not rng Is Nothing Then
'                    rng.Copy
'                    ThisWorkbook.Worksheets("452").Cells(rng.Row, "N").PasteSpecial xlPasteValues
                    'т.к. нужно только значение то не будем использовать метод "Copy"
                    ThisWorkbook.Worksheets("452").Cells(rng.Row, "N") = _
                        xlWb.Worksheets( 1 ).Cells(i, iKOT) ' название листа стоит сделать переменной

                End If
            End If
        End With
    Next

    Set rng = Nothing
    xlWb.Close False
    Set xlWb = Nothing

    Application.ScreenUpdating = True
End Sub

'********** ошибка 9
Set rng = xlWb.Worksheets(CStr(ThisWorkbook.Sheets("A3").Range("B2"))).Cells.Find( _
        "KOT", LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=True) ' <== ошибка 9
'********** ошибка  9 

msgbox CStr(ThisWorkbook.Sheets("A3").Range("B2"))
msgbox ThisWorkbook.Sheets("A3").Range("B2")

="\"&A2&".xls"

    Set rng = xlWb.Worksheets(CStr(ThisWorkbook.Sheets("A3").Range("B1"))).Cells.Find( _
        "KOT", LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=True)

    Set rng = xlWb.Worksheets(nSh).Cells.Find( _
        "KOT", LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=True)