Sub CopyDat()
    Dim Sh1 As Worksheet: Dim sAddress As String: Dim objCloseBook As Object: Dim flg As Boolean
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    Set Sh1 = ActiveSheet: flg = False
    Set objCloseBook = GetObject(ThisWorkbook.path & "\Книга2.xlsm")
    If objCloseBook.Sheets(Sh1.Name).Application.CountA(objCloseBook.Sheets(Sh1.Name).Cells) > 0 Then
        sAddress = "A1:J" & objCloseBook.Sheets(Sh1.Name).Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        If Sh1.Application.CountA(Sh1.Cells) > 0 Then
            Sh1.Range("A1:J" & Sh1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row).Clear
        End If
        objCloseBook.Sheets(Sh1.Name).Range(sAddress).Copy Destination:=[A1]: Application.CutCopyMode = False: flg = True
    Else
        MsgBox "В закрытой книге на листе """ & Sh1.Name & """ отсутствуют данные для переноса!", 48, "Info"
    End If
    On Error Resume Next
    For Each lnk In ThisWorkbook.LinkSources(xlExcelLinks)
        ThisWorkbook.BreakLink lnk, xlLinkTypeExcelLinks
    Next lnk
    On Error GoTo 0
    objCloseBook.Close False: Application.ScreenUpdating = True: [A1].Select: Application.DisplayAlerts = True
    If flg = True Then MsgBox "Готово!", 64, "Info"
End Sub

Sub Копировать_СИ_по_журналам()
    Dim wb As Workbook, c As Range, arrWB(), w
    arrWB = Array("Журнал.xlsm")
    With Application
       .EnableEvents = False
       .Calculation = xlCalculationManual
       .ScreenUpdating = False
       .Visible = False
         
        For Each w In arrWB
           'Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & w)' Этот метод копирует данные в книги ноходящиеся в одной папке с главной
            Set wb = Workbooks.Open("E:\Сервер\Сервер 1\Сервер 2\Сервер 3\Сервер 4\РАБОЧИЕ ПРОТОКОЛЫ ЭТ НТ\Журнал" & "\" & w) ' Этот метод копирует данные в книги ноходящиеся по пути с главной
            ThisWorkbook.Worksheets("Средства_измерений").Cells.Copy wb.Worksheets("Средства измерений").Cells 'копируем все данные с активного листа
            For Each c In wb.Worksheets("Средства_измерений").Cells.SpecialCells(xlCellTypeFormulas, 23)
                c.FormulaLocal = Replace(c.FormulaLocal, "[" & ThisWorkbook.Name & "]", "")
            Next c
            wb.Close (True)
        Next w
         
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .Visible = True
    End With
    MsgBox "Средства измерения скопированы в журнал"
End Sub