Private Sub DelRow()

Dim iRange As Range, iRangeDelete As Range
For Each iRange In Worksheets(1).UsedRange.Rows
If iRange.Text = "" Then
Set iRangeDelete = Union(iRange, _
IIf(iRangeDelete Is Nothing, iRange, iRangeDelete))
End If
Next
If Not iRangeDelete Is Nothing Then iRangeDelete.EntireRow.Delete

End Sub

Function Уникальные(ByVal ra As Range) As Variant
    ' перебирает все значения в диапазоне ra в поисках уникальных значений.
    ' Возвращает двумерный массив, содержащий уникальные значения из диапазона ra
    On Error Resume Next: Dim cell As Range, coll As New Collection, txt$
    For Each cell In ra.Cells
     txt$ = Trim(cell): If Len(txt$) Then coll.Add txt$, txt$
    Next cell
    ReDim newarr(1 To coll.Count, 1 To 1)
    For i = 1 To coll.Count: newarr(i, 1) = coll(i): Next i
    Уникальные = newarr
End Function

ActiveSheet.Unprotect

Sub СохранитьЛистВФайл()
    On Error Resume Next
    ' название подпапки, в которую будет сохранён файл
   Const REPORTS_FOLDER = "Технологические карты\"
   ' создаём папку для файла, если её ещё нет
    MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    ' выбираем стартовую папку
   ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    ' формируем имя файла из текста ячеек
   Filename = [b2] & "_" & [a5] & [b5] & ".xlsx"
   ' записываем в массив значения ячеек до копирования
   arr = ActiveSheet.UsedRange.Value
    ' копируем активный лист (при этом создаётся новая книга)
   Err.Clear: ActiveSheet.Copy: DoEvents
    If Err Then Exit Sub    ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
   If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
   ActiveSheet.UsedRange.Value = arr
   Columns("A:G").Delete Shift:=xlToLeft
           ' сохраняем файл под заданным именем в формате XLSX
       ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook
        ' закрываем сохранённый файл
       ActiveWorkbook.Close False
    End If
End Sub

Sub СохранитьЛистВФайл()
    On Error Resume Next
     Const REPORTS_FOLDER = "Отчёты\"
     MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
      Filename = [i6] & [j6] & ".xlsx"
      arr = ActiveSheet.UsedRange.Value
       Err.Clear: ActiveSheet.Copy: DoEvents
   If Err Then Exit Sub   
   If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
   ActiveSheet.UsedRange.Value = arr
   ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook
   ActiveWorkbook.Close False
   End If
End Sub