Sub Автозаполнение()
Dim ПредЗастр, ПредСтроит, ПредСтроитВыпРаб, ArrОбъект, ArrАкты, Sh_Шаблон, y%, i%, Temp, Indik As Boolean
Application.ScreenUpdating = False 'Выключили обновление Экрана для ускорения обработки

With Sheets("Основные параметры") 'Присваиваем значения и задаем порядок обращения к данным Ф.И.О.- Должность?
ПредЗастр = .[J2].Value & " - " & .[A2].Value
ПредСтроит = .[J4].Value & " - " & .[A4].Value
ПредСтроитВыпРаб = .[J6].Value & " - " & .[A6].Value

ArrОбъект = .Range("A9").Resize(10, 20).Value '?
ArrАкты = .Range("A30").Resize(10, .Cells(.Rows.Count, 2).End(xlUp).Row).Value '?
End With

Set Sh_Шаблон = Sheets("ШАБЛОН") 'Присваиваем имя листу, не проверяя перед этим существует ли этот лист, т.к нам это не надо

For y = 1 To UBound(ArrОбъект, 1) 'Используем функцию для определения верхней границы массива. Не понимаю что за y
If ArrОбъект(y, 8) <> "" Then 'Как следствие, понимаю только, что далее пошла проверка
'на наличие номера акта в i-той строке 2-го столбца и еслиномера нет, то дальше
'не могу понять, суть выполняемой операции Case худо-бедно понятно, а Indik вводит в ступор а как
'итог: избегаем создания дубликатов.
For i = 1 To UBound(ArrАкты, 1)
If ArrАкты(i, 2) <> "" And ArrАкты(i, 2) <> " " Then
Indik = True
For Each Sh In Sheets
Select Case Sh.Name
Case "Реестр", "Основные параметры", "ШАБЛОН"
Case Else
If Sh.[B51] = ArrАкты(i, 2) Then
Sh.Select
Indik = False
Exit For
End If
End Select
Next Sh

If Indik Then
Sh_Шаблон.Copy After:=Sheets(Worksheets.Count) 'скопируем лист АСР(как шаблон) в новый лист и в конец книги
Set Sh = ActiveSheet

On Error Resume Next
Sh.Name = "АСР " & i
If Err Then
Err.Clear
Sh.Name = "АСР " & i & "_" & Replace(Time, ":", "-")
End If
On Error GoTo 0
End If

'далее идет работа с размещением текстовых данных в необходимых диапазонах ячеек с переносом строк
            'и по прежнему это y?
            With Sh
                Temp = Строка(ArrОбъект(y, 1), 85, 1000)
                .[A15] = Temp(1): .[A16] = Temp(2)
                
                .[B51] = ArrАкты(i, 2)
                
                Temp = Строка(ПредЗастр, 40, 1000)
                .[O53] = Temp(1): .[A54] = Temp(2)
                
                Temp = Строка(ПредСтроит, 30, 1000)
                .[S57] = Temp(1): .[A58] = Temp(2)
                
                Temp = Строка(ПредСтроитВыпРаб, 58, 85)
                .[J69] = Temp(1): .[A70] = Temp(2): .[A71] = Temp(3)
                
                Temp = Строка(ArrАкты(i, 4), 30, 85)
                .[T81] = Temp(1): .[A82] = Temp(2): .[A83] = Temp(3)
                
                Temp = Строка(ArrАкты(i, 10), 40, 1000)
                .[R85] = Temp(1): .[A86] = Temp(2)
                
                Temp = Строка(ArrАкты(i, 6), 40, 85)
                .[N90] = Temp(1): .[A92] = Temp(2): .[A93] = Temp(3)
                
                Temp = Строка(ArrАкты(i, 7) & ", " & ArrАкты(i, 10), 70, 85)
                .[F96] = Temp(1): .[A97] = Temp(2): .[A99] = Temp(3)
                
                .[K101] = Day(ArrАкты(i, 8))
                .[N101] = Format(Month(ArrАкты(i, 8)), "mmmm")
                .[S101] = Year(ArrАкты(i, 8))
                
                .[K102] = Day(ArrАкты(i, 9))
                .[N102] = Format(Month(ArrАкты(i, 9)), "mmmm")
                .[S102] = Year(ArrАкты(i, 9))
                
                Temp = Строка(ArrАкты(i, 10), 85, 1000)
                .[A106] = Temp(1): .[A108] = Temp(2)
                
                Temp = Строка(ArrАкты(i, 5), 40, 1000)
                .[Q110] = Temp(1): .[A111] = Temp(2)
                
                Temp = Строка(ArrАкты(i, 7), 70, 85)
                .[F118] = Temp(1): .[A119] = Temp(2): .[A120] = Temp(3)
                
            End With
          End If
        Next i
      End If
    Next y
    Application.ScreenUpdating = True
End Sub
'тут вообще финиш, для чего создается этот массив?
Private Function Строка(sText, iSt As Integer, iEnd As Integer)
    Dim Arr(3), Temp
    If Len(sText) <= iSt Then Arr(1) = sText: GoTo ExitF:
    Temp = Left(sText, InStrRev(Left(sText, iSt), " ") - 1)
    Arr(1) = Temp
    If Len(Temp) + 2 < Len(sText) And Len(Temp) + 2 + iEnd < Len(sText) Then
        Temp = Mid(sText, Len(Temp) + 2, InStrRev(Mid(sText, Len(Temp) + 2, Len(Temp) + 2 + iEnd), " ") - 1)
        Arr(2) = Temp
        If Len(Arr(1)) + Len(Arr(2)) < Len(sText) Then
            Arr(3) = Mid(sText, Len(Arr(1)) + Len(Arr(2)) + 3)
        End If
    Else
        Arr(2) = Mid(sText, Len(Temp) + 2)
    End If
ExitF:
    Строка = Arr
End Function