Option Explicit

'https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=109916&TITLE_SEO=109916-makros-ostavlyayushchiy-stroki-po-nalichiyu-opredelyennykh-kodov&MID=911851#message911851
Sub jjj_2003()
    Dim arrData(), arrMark(), rngData As Range, i&, j&, n&, m&, k&, lCounter&, tfFlagPlus As Boolean, tfFlagMines As Boolean
    Dim arrTrgtCodes(): arrTrgtCodes = VBA.Array("IPI", "0000", "0107", "0304", "2264", "0449")
    n = UBound(arrTrgtCodes, 1)
    On Error GoTo err_handler
        With Cells(1, 1).CurrentRegion
            .Copy Workbooks.Add.Sheets(1).Range(.Address)
        End With 'Cells(1, 1).CurrentRegion
        Set rngData = ActiveSheet.UsedRange 'Cells(1, 1).CurrentRegion
        arrData = rngData.Value
        m = UBound(arrData, 1)
        ReDim arrMark(1 To m, 1 To 1)
        tfFlagPlus = False
        tfFlagMines = False
        k = 0
        For i = 1 To m
            
            arrMark(i, 1) = "-"
            
            If Len(arrData(i, 1)) > 0 Then
                For j = 0 To n
                    If arrTrgtCodes(j) = arrData(i, 1) Or Len(arrData(i, 1)) = 0 Then arrMark(i, 1) = "+": lCounter = lCounter + 1: Exit For
                Next j
            End If 'Len(arrData(i, 1)) > 0
            
            If Len(arrData(i, 1)) = 0 Or i = m Then
                If k > 0 Then
                    If lCounter = 0 Then
                        arrMark(k, 1) = "-"
                    End If 'lCounter = 0 Then
                    If Not tfFlagPlus Then If arrMark(k, 1) = "+" Then tfFlagPlus = True
                    If Not tfFlagMines Then If arrMark(k, 1) = "-" Then tfFlagMines = True
                End If 'k > 0
                
                If i < m Then arrMark(i, 1) = "+"
                k = i
                lCounter = 0
            End If 'Len(arrData(i, 1)) = 0
            
            If Not tfFlagPlus Then If arrMark(i, 1) = "+" Then tfFlagPlus = True
            If Not tfFlagMines Then If arrMark(i, 1) = "-" Then tfFlagMines = True
        Next i
        With rngData
            i = .Columns.Count + 1
            Set rngData = .Resize(, i) '.Offset(, .Columns.Count) '.Value = arrMark
        End With 'rngData
        
        If Not tfFlagPlus Then MsgBox "Öåëåâûõ êîäîâ íåò!", vbCritical: rngData.Parent.Parent.Close False: Exit Sub
        
        If tfFlagMines Then
            With rngData
                .Columns(i).Value = arrMark
                
                .Sort Key1:=.Columns(i), Order1:=xlDescending, Header:= _
                    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                    DataOption1:=xlSortNormal
                
                .AutoFilter Field:=i, Criteria1:="-"
                With .SpecialCells(xlCellTypeVisible)
                    If .Areas.Count = 1 And .Rows.Count > 1 Then
                        .Resize(.Rows.Count - 1).Offset(1).EntireRow.Delete
                    ElseIf .Areas.Count = 2 Then
                        .Areas(2).EntireRow.Delete
                    End If '.Areas.Count = 1 And .Rows.Count > 1
                End With '.SpecialCells(xlCellTypeVisible)
                .AutoFilter
                
            .Columns(i).EntireColumn.Delete
                
            End With 'rngData
        
        End If 'tfFlagMines
    On Error GoTo 0
err_handler:
    If Err <> 0 Then MsgBox Err.Number & " - " & Err.Description: Err.Clear
End Sub 'jjj_2003