Sub Main()
    Dim arr As Variant
    arr = GetArr()
    DeleteRows
    If Not IsEmpty(arr) Then FillArr arr
End Sub
'
Sub FillArr(a As Variant)
    With Sheets("Результат")
        If UBound(a, 1) > 1 Then
            .Range("B18").Resize(UBound(a, 1) - 1, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            .Rows(17).Copy .Rows(17).Resize(UBound(a, 1))
        End If
        .Range("B17").Resize(UBound(a, 1), UBound(a, 2)) = a
    End With
End Sub
'
Function GetArr() As Variant
    With Sheets("Данные")
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
        Dim a As Variant
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        a = .Range(.Cells(2, 1), .Cells(y, 15))
        
        Dim s As String
        s = Sheets("Результат").Range("K7").Value
        y = WorksheetFunction.CountIfs(.Columns(1), s)
        If y > 0 Then
            Dim b As Variant
            ReDim b(1 To y, 1 To 6)
            Dim i As Variant
            For y = 1 To UBound(a, 1)
                If a(y, 1) = s Then
                    i = i + 1
                    b(i, 1) = i
                    b(i, 2) = "АоРПИ №"
                    b(i, 3) = a(y, 2)
                    b(i, 4) = a(y, 3)
                    b(i, 5) = a(y, 10)
                    b(i, 6) = a(y, 15)
                End If
            Next
            
            GetArr = b
        End If
    End With
End Function
'
Sub DeleteRows()
    With Sheets("Результат")
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
        .Cells.EntireRow.Hidden = False
    
        Dim y As Long
        y = .Range("B16").End(xlDown).Row
        If y >= 18 Then .Range(.Cells(18, 1), .Cells(y, 1)).EntireRow.Delete
    End With
End Sub