Remove Cells That Don't Begin with One of A List of Inputs

[joshmorris23x]

Hi all,

I'm looking for a macro, that when executed, would remove all cells that don't begin with one of 3 different

For example, if I had these cells in column A:

AA
AB
BC
CD
EA
FA

And I wanted to remove anything that didn't start with "A" OR "B" OR "C"
I would be left with just these cells:

EA
FA

Any and all help is appreciated
Thanks,
Josh

 

[hiker95]

Re: How to Remove Cells That Don't Begin with One of A List of Inputs

If you wanted to end with just EA and FA you would need to remove rows that did start with A or B or C.

joshmorris23x,

If the above quote is correct, then try the following macro that does not do any looping in the rows in column A.

Sub joshmorris23x90()
'hiker95, 10/01/2017, ME1025108
Application.ScreenUpdating = False
Dim Addr As String
Addr = "A1:A" & Cells(Rows.Count, "A").End(xlUp).Row
Range(Addr) = Evaluate(Replace("IF(LEFT(@,1)=""A"",""#N/A"",@)", "@", Addr))
Range(Addr) = Evaluate(Replace("IF(LEFT(@,1)=""B"",""#N/A"",@)", "@", Addr))
Range(Addr) = Evaluate(Replace("IF(LEFT(@,1)=""C"",""#N/A"",@)", "@", Addr))
On Error GoTo NoDeletes
Columns("A").SpecialCells(xlConstants, xlErrors).EntireRow.Delete
NoDeletes:
Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Re: How to Remove Cells That Don't Begin with One of A List of Inputs

There are more. I'd like to be able to change the # of strings, but there would be no more than 5 of them.
Also, they vary in length, and won't necessarily be the same # of characters.

OK, thanks. Give this a test on a copy of your workbook.

Sub Delete_Rows_Josh()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
 
  With Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
    a = .Columns(1).Value
    ReDim b(1 To UBound(a), 1 To 1)
    With CreateObject("VBScript.RegExp")
      .Pattern = "GHI|MNO|UVWXYZ|KK" '<- add more if you want, using this pattern
      For i = 1 To UBound(a)
        If Not .Test(a(i, 1)) Then
          b(i, 1) = 1
          k = k + 1
        End If
      Next i
    End With
    If k > 0 Then
      Application.ScreenUpdating = False
      .Columns(2).Value = b
      .Sort Key1:=.Columns(2), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      .Resize(k).EntireRow.Delete
      Application.ScreenUpdating = True
      End If
  End With
End Sub

 

[Rick Rothstein]

Re: How to Remove Cells That Don't Begin with One of A List of Inputs

Here is another macro you can try...

[table="width: 500"]
[tr]
	[td]Sub DeleteRowsJosh()
  Dim X As Long, NextRow As Long, Arr As Variant, Keep As Variant, Temp As Variant
  Keep = Split("[B][COLOR="#FF0000"]GHI|MNO|UVWXYZ|KK[/COLOR][/B]", "|")  [B][COLOR="#008000"]'<- add more if you want, using this pattern[/COLOR][/B]
  Arr = Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp)))
  For X = 0 To UBound(Keep)
    Temp = Filter(Arr, Keep(X))
    NextRow = Cells(Rows.Count, "B").End(xlUp).Offset(1).Row
    If NextRow = 2 Then If Range("B1") = "" Then NextRow = 1
    If UBound(Temp) > -1 Then Cells(NextRow, "B").Resize(UBound(Temp) + 1) = Application.Transpose(Temp)
  Next
  Columns("A").Delete
End Sub[/td]
[/tr]
[/table]

Note: While the output from this macro is the same as from Peter's macro, the order of the items in the outputted list differs. Peter's code keeps the outputted items in the same order that they appear in the original list whereas my code outputs them in the order of the text searched for; that is, for the "Keep" list shown in the code above, all the text containing "GHI" will be listed first, after that will be listed all of the text containing "MNO", and so on.

 

[joshmorris23x]

Re: How to Remove Cells That Don't Begin with One of A List of Inputs

Peter, that macro works flawlessly, thank you!


Rick, that is an interesting variation. If I require that variation, i'll make sure to use it!

Thanks everyone!

 

[Peter_SSs]

Re: How to Remove Cells That Don't Begin with One of A List of Inputs

Peter, that macro works flawlessly, thank you!

You are very welcome. Glad it was what you wanted.

 

[Peter_SSs]

BTW, Rick's idea of using an array filter could be used and still keep the items in order. Here is an adaptation to do that and it is also very fast. In fact, with my test data and about 5 strings to check for, a little faster than my earlier code, but with both only taking about one tenth of a second for 25,000 rows who cares about the tiny difference?

Anyway, if you wanted to give it a whirl..

Sub DeleteRowsJM()
  Dim s As String
  Dim Keep As Variant, itm As Variant
 
  With Range("A1", Cells(Rows.Count, "A").End(xlUp))
    s = Join(Application.Transpose(.Value), "|")
    .ClearContents
    Keep = Split("GHI|MNO|UVWXYZ|KK", "|")  '<- add more if you want, using this pattern
    For Each itm In Keep
      s = Replace(s, itm, "^" & itm)
    Next itm
    Keep = Split(Replace(Join(Filter(Split(s, "|"), "^"), "|"), "^", ""), "|")
    If UBound(Keep) > -1 Then .Resize(UBound(Keep) + 1).Value = Application.Transpose(Keep)
  End With
End Sub

I've assumed "|" and "^" are characters that would not appear in the raw data.

 

[joshmorris23x]

Re: How to Remove Cells That Don't Begin with One of A List of Inputs

OK, thanks. Give this a test on a copy of your workbook.

Sub Delete_Rows_Josh()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
 
  With Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
    a = .Columns(1).Value
    ReDim b(1 To UBound(a), 1 To 1)
    With CreateObject("VBScript.RegExp")
      .Pattern = "GHI|MNO|UVWXYZ|KK" '<- add more if you want, using this pattern
      For i = 1 To UBound(a)
        If Not .Test(a(i, 1)) Then
          b(i, 1) = 1
          k = k + 1
        End If
      Next i
    End With
    If k > 0 Then
      Application.ScreenUpdating = False
      .Columns(2).Value = b
      .Sort Key1:=.Columns(2), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      .Resize(k).EntireRow.Delete
      Application.ScreenUpdating = True
      End If
  End With
End Sub

Hey, I know this is an older thread, but I have a quick request for an update on this macro:

How can I change this macro so that instead of just running on Sheet1 Column A, it loops and runs on Sheets1-10 (Sheet1, Sheet2, Sheet3, Sheet4, Sheet5, Sheet6, Sheet7, Sheet8, Sheet9, Sheet10)'s A columns?

Thanks!

 

[Peter_SSs]

Re: How to Remove Cells That Don't Begin with One of A List of Inputs

How can I change this macro so that instead of just running on Sheet1 Column A, it loops and runs on Sheets1-10 (Sheet1, Sheet2, Sheet3, Sheet4, Sheet5, Sheet6, Sheet7, Sheet8, Sheet9, Sheet10)'s A columns?

Try

Sub Delete_Rows_Josh_MultiSheet()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, sh As Long
  
  For sh = 1 To 10
    k = 0
    With Sheets("Sheet" & sh)
      With .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2)
        a = .Columns(1).Value
        ReDim b(1 To UBound(a), 1 To 1)
        With CreateObject("VBScript.RegExp")
          .Pattern = "GHI|MNO|UVWXYZ|KK" '<- add more if you want, using this pattern
          For i = 1 To UBound(a)
            If Not .Test(a(i, 1)) Then
              b(i, 1) = 1
              k = k + 1
            End If
          Next i
        End With
        If k > 0 Then
          Application.ScreenUpdating = False
          .Columns(2).Value = b
          .Sort Key1:=.Columns(2), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
          .Resize(k).EntireRow.Delete
          Application.ScreenUpdating = True
          End If
      End With
    End With
  Next sh
End Sub

 

[Ingolf]

Re: How to Remove Cells That Don't Begin with One of A List of Inputs

Hello,

How can, one of the VBA codes, be changed to delete only the cell in column A, not the whole row.

Thank you.