Sub t_ept()
NameWIn = "Отчет_10.2.03.1_«Детальный.Агрегированный» BASE.xlsx"
NameWOut = "01_Закрытие_Январь 2024_.xlsx"
For i = 5 To 44
    'NameSh = ThisWorkbook.Worksheets("main").Cells(i, 2).Value
    NameSh = "БН"
    For j = 1 To 320
        If Workbooks(NameWIn).Worksheets("Лист1").Cells(j, 1).Value = ThisWorkbook.Worksheets("main").Cells(i, 3).Value Then
            t = 1
                Do While Not Workbooks(NameWIn).Worksheets("Лист1").Cells(j + t, 1).Value Like "F_*"
                    t = t + 1
                Loop
            Workbooks(NameWIn).Worksheets("Лист1").Range(Workbooks(NameWIn).Worksheets("Лист1").Cells(j + 1, 1), Workbooks(NameWIn).Worksheets("Лист1").Cells(j + t - 1, 6)).Copy
            Workbooks(NameWOut).Worksheets(NameSh).Range("B6:G" & t + 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next j
Next i
End Sub

For j = 1 To 13
    For i = 7 To 36
        rowPL = ThisWorkbook.Worksheets("Лист").Cells(i, 2).Value
        With mySheetsPL(j)
            ThisWorkbook.Worksheets("Лист").Cells(i, j + 5).Value = .Cells(rowPL, dCol).Value 'видимо, именно эта строка занимает наибольшее время, т.к. копируется значение каждой ячейки отдельно и последовательно
        End With
    Next i
Next j

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
Old = ThisWorkbook.Worksheets("Лист1").Range("A1").Value
Pass = InputBox("Введите пароль:")
If Pass <> "000" Then
    ThisWorkbook.Worksheets("Лист1").Range("A1").Value = Old
    Exit Sub
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
Pass = InputBox("Введите пароль:")
If Pass = "000" Then
    ThisWorkbook.Worksheets("Лист1").Range("A1").Value = "ДА"
Else
    ThisWorkbook.Worksheets("Лист1").Range("A1").Value = "НЕТ"
End If
End Sub

If Application.EnableEvents.vbYesNo Then
      If a = z Then
            Application.EnableEvents.vbYes
      Else
            Application.EnableEvents.vbNo
      End If
End If 

Function Get_DirDate(path As String)
Dim a As String, D As String
D = Dir(path, vbDirectory)
While D <> ""
  If GetAttr(path & "\" & D) And vbDirectory Then
    a = D
  End If
  D = Dir
Wend
Get_DirDate = a
End Function