VBA Delete Entire Row if Doesn't Contains Certain Text

[maxbmx]

Hi guys,
Any idea of a quick macro that will help me, I would like to delete all rows that doesn't contains at least IN, CH, EL on column A

I do have many items in my stock list and I would like to keep all parts # that start by IN, CH and EL and delete all the rest that doesn't contains those 2 starts letters

Thank a lot for your help

 

[Peter_SSs]

Welcome to the MrExcel board!

.. doesn't contains at least IN, CH, EL on column A

I do have many items in my stock list and I would like to keep all parts # that start by IN, CH and EL a

'Contains' of course can be different to 'starts with'. I have assumed 'starts with'.

Give this a try in a copy of your workbook.
About how many rows of data before you do the deletions?
Asking because this code should be very quick if a large data set (& small) but simpler code could be written for a smaller data set and it would be plenty quick enough.

Sub DelUnwantedParts()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    Select Case Left(a(i, 1), 2)
      Case "IN", "CH", "EL"
      Case Else
        k = k + 1
        b(i, 1) = 1
    End Select
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[Peter_SSs]

.. but simpler code could be written for a smaller data set and it would be plenty quick enough.

Here is one such code.

Sub DelUnwantedParts_v2()
  Application.ScreenUpdating = False
  With Range("A1", Range("A" & Rows.Count).End(xlUp))
    .Replace What:="IN", Replacement:="CH@@@", LookAt:=xlPart, MatchCase:=True
    .AutoFilter Field:=1, Criteria1:="<>CH*", Operator:=xlAnd, Criteria2:="<>EL*"
    .Offset(1).EntireRow.Delete
    .AutoFilter
    .Replace What:="CH@@@", Replacement:="IN", LookAt:=xlPart, MatchCase:=True
  End With
  Application.ScreenUpdating = True
End Sub

 

[Joe4]

Welcome to the Board!

Someone can probably come up with a slicker solution that doesn't use loops, but this will get the job done:

Sub MyDelete()

    Dim lr As Long
    Dim r As Long
    Dim pfx As String
    
    Application.ScreenUpdating = False
    
'   Find last row in column A with data
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Loop through all rows backwards, up to row 2
    For r = lr To 2 Step -1
[COLOR=#ff0000]        pfx = Left(Cells(r, "A"), 2)[/COLOR]
        If (pfx = "IN") Or (pfx = "CH") Or (pfx = "EL") Then
            'do nothing
        Else
            Rows(r).Delete
        End If
    Next r
    
    Application.ScreenUpdating = True
    
End Sub

Note that this only looks for "IN", "CH", and "EL". It does not treat "in" the same as "IN".
If you want it to, then change the line in red above to:

[COLOR=#FF0000]        pfx = UCase(Left(Cells(r, "A"), 2))[/COLOR]

 

[maxbmx]

hi Peter,
looking awesome

what should I modify for:

[FONT=&quot] Case "IN", "CH", "EL”, “D”, “EV”, “EX”, “F0”, “F3”, “F7”, “GF”, “IK”, “KM”, “SH”, “T”

Thank a lot once again[/FONT]

 

[Peter_SSs]

what should I modify for:

Case "IN", "CH", "EL”, “D”, “EV”, “EX”, “F0”, “F3”, “F7”, “GF”, “IK”, “KM”, “SH”, “T”

The single characters ones don't adapt so easily to my (first) code as it was designed for 2 characters per your 3 samples. . What can follow "D" or "T"? Several examples?

My second code is not useful for a long list like this (but other options will be possible). I'll wait on the answer to my first question for now.

And what about this question:

About how many rows of data before you do the deletions?

 

[lrobbo314]

This seems to do the trick. Tested with 100k records and it ran in 0.4 seconds.

Sub deleteRows()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


Dim cnt As Long:        cnt = 0
Dim r As Range:         Set r = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim ar() As Variant:    ar = r.Value
Dim b As Boolean:       b = False
Dim cpy() As Variant
Dim vals(0 To 13) As String


vals(0) = "IN"
vals(1) = "CH"
vals(2) = "EL"
vals(3) = "D"
vals(4) = "EV"
vals(5) = "EX"
vals(6) = "F0"
vals(7) = "F3"
vals(8) = "F7"
vals(9) = "GF"
vals(10) = "IK"
vals(11) = "KM"
vals(12) = "SH"
vals(13) = "T"


For i = LBound(ar) To UBound(ar)
    For k = 0 To UBound(vals)
        If Left(ar(i, 1), Len(vals(k))) = vals(k) Then
            b = True
            Exit For
        End If
    Next k
    
    If b Then
        ReDim Preserve cpy(0 To cnt)
        cpy(cnt) = ar(i, 1)
        cnt = cnt + 1
    End If
    b = False
Next i


If cnt > 0 Then
    r.ClearContents
    Range("A2").Resize(cnt) = Application.Transpose(cpy)
End If
    
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Peter_SSs]

This seems to do the trick

I'm not so sure. It doesn't delete the entire row as requested. So if there is any data in other columns, that data will all remain & further, any connection of that data to the part number (eg cost, supplier etc) would be lost.

@ bmxmax
This is the adaptation to my previous code. It deletes the entire row for any values that do not start with the list you provided (& processed 100,000 rows in 0.024 seconds for me )

Let us know if it fails for some reason.

Sub DelUnwantedParts_v2()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
  Dim bFound As Boolean
  
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    bFound = False
    Select Case True
      Case InStr(1, "IN|CH|EL|EV|EX|F0|F3|F7|GF|IK|KM|SH", Left(a(i, 1), 2), 0) > 0: bFound = True
      Case InStr(1, "D|T", Left(a(i, 1), 1), 0) > 0: bFound = True
    End Select
    If Not bFound Then
      k = k + 1
      b(i, 1) = 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[maxbmx]

Hi Peter,
I have 5000 rows only

you last one working great but I want to switch column A to D

and I'm getting error for:

Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo

Thanks

 

[maxbmx]

And can we keep row 1 pls? Thanks