Sub Del_Empty_Rows()
 Const lCol As Long = 6
        Const lFirstRow As Long = 2
        Dim li As Long, lLastRow As Long, lCalc As Long
    With Application
        .ScreenUpdating = 0: lCalc = .Calculation: .Calculation = xlManual
        For li = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To lFirstRow Step -1
        If Cells(li, lCol) = "" Then Rows(li).Delete
        Next li
        .ScreenUpdating = 1: .Calculation = lCalc
    End With
End Sub

Private Sub Worksheet_Activate()
Dim i As Long
Dim j As Integer
Dim k&, l&, mr&
Dim iLastRow As Long
Dim iLastRow2 As Long
   Application.ScreenUpdating = False
   Cells.Clear
    iLastRow2 = Cells(Rows.Count, 1).End(xlUp).Row + 1
    With Sheets("Лист1")
      iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
      For i = 3 To iLastRow
       If Not IsEmpty(.Cells(i, 7)) Then
         For j = 4 To 6
          .Range(.Cells(i, 1), .Cells(i, 8)).Copy Cells(iLastRow2, 1)
           Cells(iLastRow2, 4) = .Cells(1, 4)
           Cells(iLastRow2, 5) = .Cells(i, 4)
           Cells(iLastRow2, 6) = .Cells(i, 5)
           Cells(iLastRow2, 7) = .Cells(i, 6)
           Cells(iLastRow2, 8) = .Cells(i, 7)
           iLastRow2 = iLastRow2 + 1

         Next
       End If
      Next
      
     mr = Range("A1").CurrentRegion.Rows.Count
    For k = 3 To mr
        For l = mr To k + 1 Step -1
            If Len(Cells(k, 1)) Then
                If Cells(k, "C") = Cells(l, "C") Then
                  If Cells(k, "E") = Cells(l, "E") Then
                    If Cells(k, "F") = Cells(l, "F") Then
                        If Cells(k, "G") = Cells(l, "G") Then
                            Rows(l).Delete
                        End If
                    End If
                  End If
                End If
            Else: Exit Sub
            End If
        Next l
    Next k
     
    End With
     
     Application.ScreenUpdating = True

End Sub