VBA to Delete rows if missing values across multiple columns

[ENicklin]

Hello,

I need to search through data from an online database and filter it based on certain criteria than can appear in multiple columns. I have copied the data into an excel sheet and the first batch is about 4k rows long and I probably only need to keep about 25% of that. My sheet is currently 7 columns wide (A-G) I need a code to search columns C, D, E and G and only keep the rows that have the following terms in them:

Cornerstone on Booth
A Different Street (JHS program)
Centre 507
Centretown CHC
Carleton University
ODSP
Emergency Medical Services
Friendship Centre, ODAWA
Haven Youth
JF Norwood, Eliz Fry
Library , Ottawa
ODAWA Native Friendship Centre
ODSP
Ontario Works
Ottawa Police
Somerset West CHC
St.Lukes
SWCHC
Tom Brown Arena
Well , The
YMCA
YMCA Employment Centre
Other (Please Specify)

I need to keep all the rows that have any of these terms in columns C, D, E, and G but if the terms are missing in all the columns then I want to delete the rows. I have found solutions to delete rows based on searches but not to keep rows and delete everything else and when I tried editing the code I just ended up deleting everything.

Any help is appreciated. Cheers,

 

[cmowla]

I'm not sure what's wrong. Do you have Office 365? Here the Workbook that I have to see if it still gives you an error. (It looks like you did exactly what I did, as you said, but just in case!)

EDIT: And I forgot to change J1 to J2 and J23 to J24. (I just put "Keywords" in J1 but forgot to change the parameters.)

 

[ENicklin]

I'm not sure what's wrong. Do you have Office 365? Here the Workbook that I have to see if it still gives you an error. (It looks like you did exactly what I did, as you said, but just in case!)

EDIT: And I forgot to change J1 to J2 and J23 to J24. (I just put "Keywords" in J1 but forgot to change the parameters.)

Apparently I don't have 365. I have Office 2019 (standard) so that is probably why it won't work.

 

[cmowla]

Apparently I don't have 365. I have Office 2019 (standard) so that is probably why it won't work.

Well I guess you will have to go with the previous poster's solution (if it works for you). Maybe I or someone can tweak this to work in your version, but I saw 365 in your profile. Oh well.

 

[ENicklin]

Well I guess you will have to go with the previous poster's solution (if it works for you). Maybe I or someone can tweak this to work in your version, but I saw 365 in your profile. Oh well.

Sorry I probably didn't fill that out correctly. Thanks again.

 

[cmowla]

Question: this did work though I realized I need one more filter. On rows that have

Sorry I probably didn't fill that out correctly. Thanks again.

There is an option to select 2019. Please change it so that you don't waste people's time in the future again, thanks!

And you could have at least checked when I mentioned this earlier since you were unsure:

Also, here's how to do this without VBA (in Office 365, which I see you have). Set up the formulas in a sheet in the following way.

 

[ENicklin]

Hi ENicklin,

Try this (initially on a copy of your data as the results cannot be undone if they're not as expected) where each of the 23 text items are in Col. A of the 'wsLookup' tab:

Option Explicit
Sub Macro1()

    Dim wsData As Worksheet, wsLookup As Worksheet
    Dim lngMyRow As Long, lngLastRow As Long
    Dim dblResult As Double
    Dim varMyCol As Variant
  
    Application.ScreenUpdating = False
  
    Set wsData = ThisWorkbook.Sheets("Sheet1") 'Sheet name that has the data in columns C, D, E and G. Change to suit if necessary.
    Set wsLookup = ThisWorkbook.Sheets("Sheet2") 'Sheet name that has filter criteria. Change to suit if necessary.
  
    If WorksheetFunction.CountA(wsData.Cells) = 0 Then
        MsgBox "There is no data in """ & wsData.Name & """ to work with.", vbExclamation
        Exit Sub
    End If
  
    lngLastRow = wsData.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For lngMyRow = lngLastRow To 2 Step -1 'Assumes the fist row of data is 2 (1 being for headers). Change to suit if necessary.
        For Each varMyCol In Array("C", "D", "E", "G") 'Columns with possible filter criteria. Change to suit if necessary.
            dblResult = dblResult + Application.WorksheetFunction.CountIf(wsLookup.Range("A:A"), wsData.Range(CStr(varMyCol) & lngMyRow)) 'Assumes criteria are in column A of 'wsLookup'. Change to suit if necessary.
            If dblResult > 0 Then
                Exit For
            End If
        Next varMyCol
        If dblResult = 0 Then
            wsData.Rows(lngMyRow).Delete
        End If
        dblResult = 0
    Next lngMyRow
  
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Thanks. This seems to work. Hopefully next time I can figure out the advanced filtering but this is good for now.

Cheers!

 

[Peter_SSs]

I can't upload a minisheet because I am on a work computer and cannot install any software.

Understood.

The list wasn't previosly recorded but I have since added a tab with that list.

OK, good.

I note that you have a working solution and speed may not be an issue for you unless the data and/or the locations list get very large but this code is roughly 30 times faster in my tests.
If you haven't done so already, you might want to move your button up to row 1 so that can't get affected by row deletions.
This code requires that there are no blank cells in the Locations list but that seems to be the case anyway.
If you want to test this code, do so with a copy of your workbook
I have assumed that the data sheet (2018 in your case) is the active sheet when the code is run. I guess that will be the case if you are going to run the code from the button in that sheet.

Sub Del_Rows()
  Dim RX As Object
  Dim a As Variant, b As Variant
  Dim lr As Long, i As Long, k As Long

  Application.ScreenUpdating = False
  lr = Sheets("Locations").Range("A" & Rows.Count).End(xlUp).Row
  Set RX = CreateObject("VBScript.RegExp")
  RX.Pattern = Join(Application.Transpose(Sheets("Locations").Range("A1:A" & lr).Value), "|")
  With Range("A2:H" & Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)
    .Columns(8).Formula = "=TextJoin(""#"", 1, C2, D2, E2, G2)"
    a = .Columns(8).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If Not RX.test(a(i, 1)) Then
        b(i, 1) = 1
        k = k + 1
      End If
    Next i
    .Columns(8).Value = b
    If k > 0 Then
      .Sort Key1:=.Columns(8), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End If
  End With
  Application.ScreenUpdating = True
End Sub