ActiveWorkbook.SaveAs p & "\"  & Filename1 & ".xls"  

Option Explicit

Sub perenos1()

Dim i As Long
Dim last As Long
Dim last1 As Long
Dim found As Range
Dim word1 As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
If Workbooks.Count Then
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
End If
Application.DisplayStatusBar = False
Application.DisplayAlerts = False

last = Worksheets("Выгрузка").Cells(Rows.Count, 70).End(xlUp).Row
last1 = Worksheets("Лист").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To last

word1 = "*Ошибка*"

Set found = Worksheets("Выгрузка").Cells(i, 70).Find(word1)

If Not found Is Nothing Then

Worksheets("Лист").Cells(last1 + 1, 1).Resize(, 30).Value = Worksheets("Выгрузка").Cells(i, 70).Resize(, 30).Value
last1 = last1 + 1

End If
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
If Workbooks.Count Then
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = True
End If
Application.DisplayStatusBar = True
Application.DisplayAlerts = True 
End Sub

Option Explicit

Sub VPR()
Dim last As Long
Dim i As Long

Dim old As String
Dim old2 As String
Dim newtext As String
Dim newtext2 As String

Dim x As String
Dim y As String

last = Worksheets("ВПР").Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets("ВПР")

For i = 2 To last

x = .Cells(i, "B")
y = .Cells(i, "C")

old = "Компьютер не сломан*"
newtext = "Компьютер сломан"
old2 = "*Починить. Починить."
newtext2 = "*Починить."

If y = "нет" Then x = Replace(old, "Компьютер не сломан", newtext) & " Починить."
If x = "*Починить. Починить." Then x = Replace(old2, "*Починить. Починить.", newtext2)


Next

End With
End Sub

application.cutcopymode=false

Option Explicit

Sub Zadacha_2()
Application.ScreenUpdating = False 'инструкция для отключения обновления экрана во время отработки кода (д/быстродействия)

Dim arrTable As Variant 'переменная variant для таблицы-массива

arrTable = Worksheets("Решение").Range("A1:C10") 'где находится массив, обозначение его границ
arrTable.Copy 'копировать массив
Sheets.Add After:=ActiveSheet 'создать новый лист после листа "Решение"

ActiveSheet.Paste 'вставить скопированный массив в новый лист
ActiveSheet.Name = "1" 'присвоить листу имя "1"

Application.ScreenUpdating = True 'д/включения обновления экрана
End Sub

=СУММЕСЛИ($G$1:$G$3;A1;ЕСЛИ(И(H1>=16;H1<=18);0;$H$1:$H$3))