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 = Тrue End Sub