Dim i As Range, j&, k&
ReDim v(1 To 1048576, 1 To 1)
For Each i In [A:A].SpecialCells(xlCellTypeConstants, xlNumbers)
   For j = i To i(, 2)
       k = k + 1
       v(k, 1) = j
   Next
Next
[E2:E1048576].Value = v
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim iCell As Range
On Error Resume Next
If Not Intersect(Target, Intersect(Me.UsedRange, Me.Columns(1))) Is Nothing And Target.Count = 1 Then
    Set iCell = Worksheets("СТ-PL").Columns(1).Find(Target.Value)
    If Not iCell Is Nothing Then
        Target.Offset(i, 3).Value = iCell.Offset(i, 3).Value
        Target.Offset(i, 4).Value = iCell.Offset(i, 4).Value
    Else
        Target.Offset(i, 3).Value = Empty
        Target.Offset(i, 4).Value = Empty
    End If
End If


End Sub

Private Sub Worksheet_Change(ByVal Target As Range)


Dim arr(), lR As Long, i As Long
    
   If Intersect(Target, Columns("AT:BE")) Is Nothing Then Exit Sub
 '      Application.ScreenUpdating = False
        lR = Cells(Rows.Count, "BF").End(xlUp).Row
    Application.EnableEvents = False
    Range("BF1:BF" & lR).ClearContents
    'Application.EnableEvents = True
        lR = Columns("AT:BE").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    ReDim arr(1 To lR, 1 To 1)
    For i = 1 To lR
        arr(i, 1) = WorksheetFunction.Sum(Cells(i, "AT").Resize(, 12))
        
    Next i
    Application.EnableEvents = False
   Range("BF1").Resize(UBound(arr)).Value = arr()
   
   [BF1] = Application.Sum([BF2:BF1000])

End Sub

Dim arr(), lR As Long, i As Long

   If Intersect(Target, Columns("AT:BE")) Is Nothing Then Exit Sub
 '      Application.ScreenUpdating = False
        lR = Cells(Rows.Count, "BF").End(xlUp).Row
    Application.EnableEvents = False
    Range("BF1:BF" & lR).ClearContents
    'Application.EnableEvents = True
        lR = Columns("AT:BE").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    'ReDim arr(1 To lR, 1 To 1)
    For i = 1 To lR
        Cells(i, 58) = Cells(i, 46) + Cells(i, 47) + Cells(i, 48) + Cells(i, 49) + Cells(i, 50) + Cells(i, 51) + Cells(i, 52) + Cells(i, 53) + Cells(i, 54) + Cells(i, 55) + Cells(i, 56) + Cells(i, 57)
    Next i
    Application.EnableEvents = False
   Range("BF1").Resize(UBound(arr)).Value = arr()

   [BF1] = Application.Sum([BF2:BF1000])
   ' Application.EnableEvents = True

Sub CopyVsVsio()
Application.EnableEvents = False
    Worksheets("Строка").Range("A2:BF2").Copy Worksheets("Заполнять").Range("A" & Worksheets("Заполнять"). _
    UsedRange.Rows.Count + 1)
    Application.CutCopyMode = False
    Application.EnableEvents = True
    MsgBox "Новая строка добавлена!"
End Sub

Sub COLOR()
Dim Rng As Range
Dim n
Dim rData
 
'Dim RndMY
    With Worksheets("Заполнять")
        Set Rng = .Range("G:G")
 
        For Each n In Rng
                   
        Select Case n
                Case "сущ"
                     Range(Cells(n.Row, 1), Cells(n.Row, 58)).Interior.ColorIndex = 0
                Case "план"
                     Range(Cells(n.Row, 1), Cells(n.Row, 58)).Interior.ColorIndex = 19
                Case "откл"
                     Range(Cells(n.Row, 1), Cells(n.Row, 58)).Interior.ColorIndex = 15
    
            End Select
        Next n
    End With
End Sub

If Not Intersect(Target, Range("G:G")) Is Nothing Then
   If Target > 0 Then
     Call COLOR
   End If
 End If