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
Pass = InputBox("Введите пароль:")
If Pass = "000" Then
    ThisWorkbook.Worksheets("Лист1").Range("A1").Value = "ДА"
Else
    ThisWorkbook.Worksheets("Лист1").Range("A1").Value = "НЕТ"
End If
End Sub

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

Sub Резчик()
    Dim FolderPath As String
    FolderPath = Application.ActiveWorkbook.Path
    Dim currentWS As Worksheet
    Set currentWS = ActiveSheet
    Dim totalRows, startFrom As Integer
    totalRows = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
    startFrom = 6
    For i = startFrom To totalRows
        CompileRow i, currentWS, FolderPath
    Next i
End Sub

Sub CompileRow(row, currentWS, FolderPath)
    Dim NewBook As Workbook
    Set NewBook = Workbooks.Add
    currentWS.Copy Before:=NewBook.Worksheets(1)
    Dim newWS As Worksheet
    Set newWS = NewBook.Worksheets(1)
    newWS.Activate
    Dim title As String
    title = Range("A" & row).Value
    ww = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
    For t = ww To 6 Step -1
        If t <> row Then
            newWS.Cells(t, 1).EntireRow.Delete
        End If
    Next t
    With NewBook
        .title = title
        .SaveAs Filename:=FolderPath & "/" & "_" & title & ".xlsb", FileFormat:=50
        .Close
    End With
End Sub

ThisWorkbook.Worksheets("26-Out").Range("$E$10:$F$13").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

ThisWorkbook.Worksheets("26-Out").Range(ThisWorkbook.Worksheets("26-Out").Cells(11, 5), ThisWorkbook.Worksheets("26-Out").Cells(13, 6)).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
ActiveSheet.Range...

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("С1:С10")) Is Nothing Then ' ищу изменения в столбце С, тут ругается
            Ans = MsgBox("Вы уверены, что хотите добавить запись?", vbYesNo, "Внимание!")
            If Ans = vbNo Then Exit Sub        
            For i = 1 To 10 ' ищу максимум в существующих номерах записей
                Nominal = 0
                If Cells(i, 1) > Nominal Then
                    Nominal = Nominal + 1
                End If
            Next i            
            If Cells(Target.Row, 1) = 0 Then ' записываю новый номер записи
                    Target = Nominal + 1
            End If    
    End If
End Sub

ThisWorkbook.XmlImport URL:=f, ImportMap:=Nothing, Overwrite:=True, Destination:=Range("$A$1")

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, Range("A1:B10")) Is Nothing Then
            Application.EnableEvents = False
                If Cells(Target.Row, 3) = 0 Then
                    Target.Font.Name = "Marlett"
                    Target = "a"
                    Application.EnableEvents = True
                End If
            Exit Sub
        End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, ThisWorkbook.Worksheets("Лист2").Range("J2:P2")) Then Exit Sub
For i = 10 To 16
    If ThisWorkbook.Worksheets("Лист2").Cells(2, i) <> 1 Then
        ThisWorkbook.Worksheets("Лист2").Columns(i).EntireColumn.Hidden = True
    Else
        ThisWorkbook.Worksheets("Лист2").Columns(i).EntireColumn.Hidden = False
    End If
Next i
End Sub

vData = ActiveWorkbook.Worksheets(1).Range(ActiveWorkbook.Sheets(1).Cells(11, 1), ActiveWorkbook.Sheets(1).Cells(CountRows, 14)).SpecialCells(xlVisible).Value