Deleting row if keyword not found

[kaffal]

I would like to have a macro to loop through all the worksheet except for "Summary" worksheet.

The macro will look for the keyword in the worksheet starting from row 2 from every sheet.

if the keyword is found on the row, the entire row will be deleted and shift row up.
Keyword for example is found in H13 in the Summary worksheet

Excel Workbook
	G	H
13	Keyword	London
Summary

 

[Colin Legg]

Here is an example.

It will delete the search word in cell Summary!H13 from Row 2 downwards on all worksheets except for the Summary worksheet.

Sub Example()
    Dim wst As Worksheet, sFirstAddress As String
    Dim rngFound As Range, rngToDelete As Range
    
    On Error GoTo ErrorHandler
    
    With Application
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    For Each wst In ActiveWorkbook.Worksheets
        With wst
            If .Name <> "Summary" Then
                With .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count))
                    Set rngFound = .Find( _
                                        What:=Worksheets("Summary").Range("H13").Value, _
                                        After:=.Cells(1), _
                                        Lookat:=xlPart, _
                                        SearchOrder:=xlByRows, _
                                        SearchDirection:=xlNext, _
                                        MatchCase:=False)
                    
                    If Not rngFound Is Nothing Then
                        sFirstAddress = rngFound.Address
                        
                        If rngToDelete Is Nothing Then
                            Set rngToDelete = rngFound
                        Else
                            'we can only have one range reference per row.
                            If Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
                                Set rngToDelete = Union(rngToDelete, rngFound)
                            End If
                        End If
                        
                        Set rngFound = .FindNext(After:=rngFound)
                        
                        Do Until rngFound.Address = sFirstAddress
                            If Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
                                Set rngToDelete = Union(rngToDelete, rngFound)
                            End If
                            Set rngFound = .FindNext(After:=rngFound)
                        Loop
                        
                    End If
                End With
            
                If Not rngToDelete Is Nothing Then
                    rngToDelete.EntireRow.Delete
                    Set rngToDelete = Nothing
                End If
            
            End If
        End With
    Next wst
ErrorExit:
    
    With Application
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Number & vbLf & Err.Description
    Resume ErrorExit
End Sub

 

[kaffal]

Hi, it works perfectly.
But instead of delete those rows that contain, can I use a keyword to delete the row if the row does not contain the keyword from row 2 onward

 

[Colin Legg]

Hi,

We can't do that quite as efficiently.

To literally check each row on each sheet to see if the keyword is absent then we would use something like this:

Sub Example2()
    Dim wst As Worksheet, rngFound As Range, rngLastCell As Range
    Dim rngCell As Range, rngToDelete As Range
 
    On Error GoTo ErrorHandler
    With Application
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
 
    For Each wst In ActiveWorkbook.Worksheets
        With wst
            If .Name <> "Summary" Then
                With .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count))
                    Set rngLastCell = .Find(What:="*", After:=.Cells(1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
                End With
 
                If Not rngLastCell Is Nothing Then
                    For Each rngCell In .Range(.Cells(2, 1), .Cells(rngLastCell.Row, 1))
                        With rngCell
                            Set rngFound = .EntireRow.Find( _
                                            What:=Worksheets("Summary").Range("H13").Value, _
                                            After:=.Cells(1), _
                                            Lookat:=xlPart, _
                                            SearchOrder:=xlByRows, _
                                            SearchDirection:=xlNext, _
                                            MatchCase:=False)
                        End With
 
                        If rngFound Is Nothing Then
                            If rngToDelete Is Nothing Then
                                Set rngToDelete = rngCell
                            Else
                                Set rngToDelete = Union(rngToDelete, rngCell)
                            End If
                        End If
                    Next rngCell
                End If
 
                If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
                Set rngToDelete = Nothing
 
            End If        'If .Name <> "Summary" Then
        End With
    Next wst
ErrorExit:
 
    With Application
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
 
    Exit Sub
 
ErrorHandler:
    MsgBox Err.Number & vbLf & Err.Description
    Resume ErrorExit
End Sub

But if you have a lot of rows of data then this may take some time to run.

A better approach for you to consider might be to find the rows you want to keep (ie. the ones containing the keyword), copy them to another sheet, clear the sheet, and then copy the rows back again. I think that's how I would go about this.

 

[Colin Legg]

Follow up...

I received a PM from member Asus requesting a similar solution to the one above, except using a list of keywords from a Master sheet rather than a single keyword.

So this will clear all rows in all worksheets (except for the master worksheet) if none of the keywords are contained on that row. It assumes that the first row in each worksheet is a header row and should be left alone.

Sub Example3()
    Dim wst As Worksheet, rngFound As Range, rngLastCell As Range
    Dim rngCell As Range, rngToKeep As Range
    Dim rngKeywords As Range, wstTemp As Worksheet
    Dim sFirstAddress As String
 
    On Error GoTo ErrorHandler
 
    With Application
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
 
    'the range containing the list of keywords we want to keep
    Set rngKeywords = ActiveWorkbook.Worksheets("Master").Range("A1:A9")
 
    For Each wst In ActiveWorkbook.Worksheets
        With wst
            If .Name <> rngKeywords.Parent.Name Then
 
                With .Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count))
 
                    'loop through the keyword range and try to find the keywords
                    For Each rngCell In rngKeywords
 
                        'ignore empty cells
                        If LenB(rngCell.Value) > 0 Then
 
                            'try to find the keyword
                            Set rngFound = .Find( _
                                            What:=rngCell.Value, _
                                            After:=.Cells(1), _
                                            Lookat:=xlWhole, _
                                            SearchOrder:=xlByRows, _
                                            SearchDirection:=xlNext, _
                                            MatchCase:=False)
 
 
                            'if we found it then make a note and then try to find more
                            If Not rngFound Is Nothing Then
                                sFirstAddress = rngFound.Address
 
                                If rngToKeep Is Nothing Then
                                    Set rngToKeep = rngFound
                                Else
                                    Set rngToKeep = Union(rngToKeep, rngFound)
                                End If
 
                                Set rngFound = .FindNext(After:=rngFound)
 
                                Do Until rngFound.Address = sFirstAddress
                                    If Intersect(rngToKeep, rngFound.EntireRow) Is Nothing Then
                                        Set rngToKeep = Union(rngToKeep, rngFound)
                                    End If
                                    Set rngFound = .FindNext(After:=rngFound)
                                Loop
                            End If
                        End If
                    Next rngCell
 
 
                    'if we didn't find any keywords then we can just clear the sheet from A2 downwards
                    If rngToKeep Is Nothing Then
                        .Clear
 
                    Else
                        'otherwise let's put the rows we want to keep on a temporary sheet
                        If wstTemp Is Nothing Then Set wstTemp = ActiveWorkbook.Worksheets.Add
                        Intersect(rngToKeep.EntireRow, .Parent.Columns(1)).EntireRow.Copy wstTemp.Range("A1")
 
                        'now we can clear the sheet from A2 downwards
                        .Clear
 
                        With wstTemp.UsedRange
                            'now we can copy the rows back onto the sheet again
                            .Copy wst.Range("A2")
                            'and clear the temporary sheet for the next run
                            .Clear
                        End With
 
                        Set rngToKeep = Nothing
                    End If
                End With
            End If        'If .Name <> "Master" Then
        End With
    Next wst
 
ErrorExit:
 
    'delete the temporary sheet if there is one
    If Not wstTemp Is Nothing Then wstTemp.Delete
 
    With Application
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
 
    Exit Sub
 
ErrorHandler:
    MsgBox Err.Number & vbLf & Err.Description
    Resume ErrorExit
End Sub

 

[kaffal]

hi Colin, how about deleting column that does not found in the row 1(heading) using list of key words ?
- same thing, master worksheet will not be be included
- in all the other sheet, it will look only at row 1. if any of the cell value, except for blank cell, does not included in the list of keywords, the whole column will be deleted and shift the cell left

 

[ethical]

Hi Colin,

your script looks very helpful however I know nothing at all about macros and what i want to do is the exact opposite of what you have posted above.

I want to remove any rows that DO contain the keywords that exist in the range of keywords specified.

any help would be greatly appreciated.

I will tinker with it to see if I can change it around but I am not too hopeful..

 

[ethical]

Hi Colin,

your script looks very helpful however I know nothing at all about macros and what i want to do is the exact opposite of what you have posted above.

I want to remove any rows that DO contain the keywords that exist in the range of keywords specified.

any help would be greatly appreciated.

I will tinker with it to see if I can change it around but I am not too hopeful..

 

[Colin Legg]

Hi Ethical,

I posted some code template examples here. From your description, I think post #6 matches your requirements, but have a read through the rest of the thread so it makes more sense. It's a 'code library' piece rather than a 'tutorial' so the code is not explained in a lot of depth - feel free to ask any questions here if you're unsure about something.

Hope that helps...

 

[ethical]

Hi Colin,

thanks! I did find those after posting but I was unclear how to change the ARRAY that you had there to be a defined set of cells (a range of cells) instead for defining the keywords I want to filter against?

if you have advice for that I think it would get me going!

thanks so much for your reply!

John