Sub DelRows1()
Application.ScreenUpdating = False
Dim x, i As Long
x = Range([A5], Cells(Rows.Count, 1).End(xlUp)).Value
For i = 5 To UBound(x) Step 0
'If Application.WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, 3))) < 3 Then
Rows(i).Delete
'End If
Next
End Sub

Option Explicit

Sub с_листа_данные()
       Dim x, z(), i As Long, ii&
       Application.ScreenUpdating = False
       With Sheets("данные")        'на РСВ
           x = .Range("B5:R" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
       End With
       ReDim z(1 To UBound(x), 1 To 16)

       With CreateObject("Scripting.dictionary")
           .CompareMode = 1    'TextCompare

           For i = 1 To UBound(x)
               If Not .exists(x(i, 1)) Then
                   .Item(x(i, 1)) = CStr(i)
                   ii = ii + 1
                   z(ii, 1) = x(i, 2) & "-" & x(i, 10) & " " & x(i, 7)
                   z(ii, 2) = x(i, 1)
                   z(ii, 3) = x(i, 2)
                   z(ii, 4) = x(i, 3)
                   z(ii, 5) = x(i, 4)
                   z(ii, 6) = x(i, 5)
                   z(ii, 7) = x(i, 7)
                   z(ii, 8) = x(i, 8)
                   z(ii, 9) = x(i, 9)
                   z(ii, 10) = x(i, 6)
                   z(ii, 11) = x(i, 10)
                   z(ii, 12) = x(i, 11) & " " & Left(x(i, 12), 1) & "." & Left(x(i, 13), 1) & "."
                   z(ii, 13) = x(i, 14)
                   z(ii, 14) = x(i, 15)
                   z(ii, 15) = x(i, 16)
                   z(ii, 16) = x(i, 17)
               End If
           Next i

       End With

       Range("A5:P" & Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
       With [a5:p5].Resize(ii)
           .Value = z
       End With
       Application.ScreenUpdating = True
End Sub