Sub Copy()
    Dim FS As Object, KATALOG As Object, FILE As Object, MASSIV As Object
    Dim katal As String
    Dim Rng As Range
    Dim wb As Workbook
       katal = GetFolderPath("Выбрать каталог", ThisWorkbook.Path)
       If katal = "" Then Exit Sub
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set KATALOG = FS.GetFolder(katal)
    Set MASSIV = KATALOG.Files
    
    For Each FILE In MASSIV
       Set wb = Workbooks.Open(Filename:=FILE)        
       If IsSheetExist(wb, "Лист1") Then
            wb.Sheets("Лист1").Select
            Set Rng = ThisWorkbook.Worksheets("Лист1").Range("B5")
            Rng.Copy Destination:=wb.Sheets("Лист1").Range("B5")
            wb.Save
        End If
        wb.Close
    Next
    End Sub
Private Function IsSheetExist(ByVal wb As Workbook, ByVal sName As String) As Boolean
    On Error Resume Next
    With wb.Worksheets(CStr(sName)): End With
    IsSheetExist = (Err = 0)
    Err.Clear
End Function
Function GetFolderPath(Optional ByVal Title As String = "Выбрать папку", _
                       Optional ByVal InitialPath As String = "c:\") 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