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]

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

If your part numbers are in column D instead of column A, the only change required is

a = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value

Do not change the "A2" near the bottom of the code.

I have not been able to reproduce the error you report. If you still get the error, please provide the full error message and what the value of nc is when you click Debug and hover over nc in the yellow line of code.

And can we keep row 1 pls?

My code does not touch row 1 anyway.

 

[maxbmx]

Hi Peter,
Working great but only getting that small issue about row 1 that got delete and row 2 come the row 1

thank a lot for your time on my story

 

[Peter_SSs]

getting that small issue about row 1 that got delete and row 2 come the row 1

Please copy and post the full code that you are now using.

As I stated before, my code does not do anything with row 1. My code interacts with the worksheet twice only.

First time is to read all the column D data starting from row 2 only into memory.

Second time is to write some temporary data back to the sheet and get rid of the unwanted rows but that whole section only deals with the sheet from row 2 downwards.

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("D2", Range("D" & Rows.Count).End(xlUp)).Value '<- That is, from row 2 downwards
  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) '<- That is, from row 2 downwards
      .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 understand but unfortunately row 1 got delete and row 2 come the row 1

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("D2", Range("D" & 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|D3|TI|TK", Left(a(i, 1), 2), 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]

Peter,
Sorry all good, working great now

bug on my side

Thanks

 

[Peter_SSs]

Peter,
Sorry all good, working great now

bug on my side

Thanks

You're welcome. Glad you got it sorted.

BTW, when posting code, please use Code Tags to preserve the indentation in the code, making it easier for others to read/debug, copy with indentations. I have added them to post 14 for you and my signature block below explains how to do it.