Sub КопироватьДанные()
    ' объявляем переменные
    Dim ЛистКопирования$, ДиапазонКопирования$, ЛистВставки$, ДиапазонВставки$, lLastRow As Long
    ЛистКопирования$ = Sheets("Настройки").[D7]    ' берём из ячейки
    ДиапазонКопирования$ = Sheets("Настройки").[D8]    ' берём из ячейки
    ЛистВставки$ = Sheets("Настройки").[D9]    ' берём из ячейки
    ДиапазонВставки$ = Sheets("Настройки").[D10]    ' берём из ячейки
    Dim RangeList As Variant
    RangeList = Application.WorksheetFunction.CountA([D15:D115])
    Dim i As Long
    Worksheets(ЛистВставки).Cells.ClearContents 'очистить область вставки
    
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlManual: End With
        For i = 1 To RangeList
            'Открываем другой файл'
            Dim WB As Workbook, Sht As Worksheet, Rng As Range
            Set WB = Application.Workbooks.Open(Workbooks("Сбор данных (П-1).xlsm").Sheets("Настройки").Cells(i + 14, 4), Password:="")
            Set Sht = WB.Sheets(ЛистКопирования)
            Set Rng = Sht.Range(ДиапазонКопирования)
            'определили последнюю заполненную ячейку
            lLastRow = ThisWorkbook.Sheets(ЛистВставки).Cells(Rows.Count, ДиапазонВставки).End(xlUp).Row
            Rng.Copy
            ThisWorkbook.Sheets(ЛистВставки).Range(ДиапазонВставки & lLastRow + 1).PasteSpecial xlPasteValues
            WB.Close False
            Set WB = Nothing: Set Sht = Nothing: Set Rng = Nothing
        Next
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: End With
    'Set sht = Nothing
    ThisWorkbook.Sheets(ЛистВставки).Activate
End Sub

If Target = "Н" Or Target = "н" Then
    Set TargetGlobal = Target
    From_Unit.Show
    End If

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [F10:AJ209]) Is Nothing Then
        If Target = "ДЦ" Or Target = "дц" Then
        From_Unit.Show
        End If
End If
End Sub
 

 "ДЦ"

Option Explicit
Private Sub Submit_OK_Click()
If Box_Unit.Text <> "" Then
    Dim kz&
    kz = Sheets("ДЦ").UsedRange.Rows.Count + 1
    Range("ДЦ!A" & kz).Value = Intersect(Columns(3), Target.EntireRow).Value
    Range("ДЦ!B" & kz).Value = Box_Unit.Value
    Range("ДЦ!C" & kz).Value = ActiveSheet.Name
    Range("ДЦ!D" & kz).Value = Intersect(Rows(7), Target.EntireColumn).Value
    
    Me.Hide
End If
End Sub