Deleting or keeping multiple rows by a specific word content - vba

Question

I'm trying to write a code that either deletes or keeps rows by a specific word input by the end-user.
I've created two button actions:
Sub Button1_Click()
Dim cell As Range
word1 = InputBox("Enter a word by which you want to keep rows", "Enter")
For Each cell In Selection
cell.EntireRow.Hidden = (InStr(1, cell, word1, 1) = 0) 'keep by a word input by the user
Next
End Sub
Sub Button2_Click()
Dim cell As Range
word2 = InputBox("Enter a word by which you want to delete rows", "Enter")
For Each cell In Selection
cell.EntireRow.Hidden = (InStr(1, cell, word2, 1) = 1) 'delete by a word input by the user
Next
End Sub
However, these buttons don't work quite the way I would like them to do.
Problems:
1) I have to specifically select the cells in the column of the text to be searched; if I select the whole block of data,everything will be deleted.
2) Actually, the program would be handier, if it did its magic from the cell J22 onwards (to the right and downwards) until the end of the data is reached, without the need to select anything. What is the best way to do this?
3) If I use these buttons several times sequentially, the rows that I've already deleted keep popping up again. How to make the delete "permanent" each time I use one of these buttons? By changing Hidden to Delete I start to get run-time errors.

Answer 1

When you attempt to delete permanently the macro deletes a row, shifts all of the other rows up one to accomodate and this disrupts the flow of your 'For Each...Next'.
There are a couple of ways around this either way it very much changes the shape of your code.
One of them is to add the rows you wish to delete to a union during the loop and then delete the union outside of the loop (example A below). In any case it sounds like you want to specify the range you want this code to work on so I've incorporated that into each example.
Example A
Sub Button1_Click()
Dim endR As Integer, endC As Integer 'depending on size of sheet may need to change to Long
Dim cell As Range, rng As Range, U As Range
Dim ws As Worksheet
Set ws = Sheets(2) ' change accordingly
endR = ws.UsedRange.Rows.Count
endC = ws.UsedRange.Columns.Count
Set rng = Range(ws.Cells(22, 10), ws.Cells(endR, endC)) ' from cell J22 to last used row of the last used column on the right
word1 = InputBox("Enter a word by which you want to keep rows", "Enter")
For Each cell In rng
If InStr(1, cell, word1, 1) = 0 Then
If U Is Nothing Then ' for the first time the code finds a match
Set U = cell.EntireRow ' add row to be deleted to U variable
Else
Set U = Union(U, cell.EntireRow) ' for any subsequent matches, add row to be deleted to Union
End If
End If
Next
U.Delete
End Sub
The other way to do it would be to define the exact ranges you want to work with at the start of your code and then loop backwards through that range using loop control variables instead of for each, that way when you delete a row, the shift up doesn't impact the loop.
Sub Button2_Click()
Dim r As Integer, c As Integer
Dim endR As Integer, endC As Integer
Dim cell As Range, rng As Range
Dim ws As Worksheet
Set ws = Sheets(2) ' change accordingly
endC = ws.UsedRange.Columns.Count
word2 = InputBox("Enter a word by which you want to delete rows", "Enter")
For c = 10 To endC ' start from J and move to the right
endR = ws.UsedRange.Rows.Count ' after each column has been dealt with, re-evaluate the total rows in the worksheet
For r = endR To 22 Step -1 ' start from the last row and work up
If InStr(1, ws.Cells(r, c), word2, 1) = 1 Then
ws.Cells(r, c).EntireRow.Delete
End If
Next r
Next c
End Sub

Answer 2

With your current code, if you select the whole block of data, it checks each cell in that selection individually and acts accordingly. If you have a range selected like A1:J1,000, it will hide every row unless each cell in every row of the selection contains the input word.
Depending on what you exactly want, you could try something Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.count, 10).End(xlUp).Row this returns the rownumber of the last cell in column 10(J), more examples of this in the code below
This is caused by the for loop and the deletion of rows, say For i = 1 To 100 you check cells A1 to A100, if you then delete a row during that loop, the loop will still continue to 100 and not end at 99, the end of the loop is set before the loop starts and does not change during the loop. More information on that and it's solutions here.
General
Avoid the .Select/.Activate methods and .Selection property, it is a source of many bugs.
Declare all your variables, use Option Explicit to enforce this.
Here is the refactored code with annotations.
Option Explicit
Sub Button1_Click()
'Keep rows based on input
'Declaration of variables
Dim i As Long
Dim strFilterWord As String
Dim rngCell As Range
Dim rngToDelete As Range, rngRow As Range
Dim arrRow() As Variant, arrTmp() As Variant
'Setting the filter word
strFilterWord = InputBox("Enter a word by which you want to keep rows", "Enter")
With ThisWorkbook.Worksheets("Sheet1") 'Replace "Sheet1" with the actual name of your sheet.
'Setting up for loop, currently range to loop over is J22:J(lastrow with data)
For Each rngCell In .Range(.Cells(22, 10), .Cells(Rows.Count, 10).End(xlUp))
'All values of the current row are combined into an array
'Determining and setting the range of the current row
Set rngRow = rngCell.Resize(1, 3)
'Populate a tmp array with the row range values
arrTmp = rngRow
'To use the array, it needs to be 1D, currently it is 2D, section below accomplishes this
'resize the final array
ReDim arrRow(LBound(arrTmp, 2) To UBound(arrTmp, 2))
'Copy values to final array
For i = LBound(arrTmp, 2) To UBound(arrTmp, 2)
arrRow(i) = arrTmp(1, i)
Next i
'the final array is combined to a single string value with " "(spaces) between each array element
'if the filterword is not found in the string Instr returns a 0
'If the filterword is found in the string InStr returns a number corresponding to the start position.
If InStr(1, Join(arrRow, " "), strFilterWord, vbTextCompare) = 0 Then
'Test to see if the range to delete is empty or not
If rngToDelete Is Nothing Then
'If the range is empty, it is set to the first row to delete.
Set rngToDelete = rngCell.EntireRow
Else
'if the range is not empty, the row to delete is added to the range.
Set rngToDelete = Union(rngToDelete, rngCell.EntireRow)
End If
End If
Next rngCell
'After all cells are looped over, the rows to delete are deleted in one go
If Not rngToDelete Is Nothing Then rngToDelete.Delete
End With
End Sub
Sub Button2_Click()
'Keep rows based on input
'Declaration of variables
Dim i As Long
Dim strFilterWord As String
Dim rngCell As Range
Dim rngToDelete As Range, rngRow As Range
Dim arrRow() As Variant, arrTmp() As Variant
'Setting the filter word
strFilterWord = InputBox("Enter a word by which you want to delete rows", "Enter")
With ThisWorkbook.Worksheets("Sheet1") 'Replace "Sheet1" with the actual name of your sheet.
'Setting up for loop, currently range to loop over is J22:J(lastrow with data)
For Each rngCell In .Range(.Cells(22, 10), .Cells(Rows.Count, 10).End(xlUp))
'All values of the current row are combined into an array
'Determining and setting the range of the current row
Set rngRow = rngCell.Resize(1, 3)
'Populate a tmp array with the row range values
arrTmp = rngRow
'To use the array, it needs to be 1D, currently it is 2D, section below accomplishes this
'resize the final array
ReDim arrRow(LBound(arrTmp, 2) To UBound(arrTmp, 2))
'Copy values to final array
For i = LBound(arrTmp, 2) To UBound(arrTmp, 2)
arrRow(i) = arrTmp(1, i)
Next i
'the final array is combined to a single string value with " "(spaces) between each array element
'if the filterword is not found in the string Instr returns a 0
'If the filterword is found in the string InStr returns a number corresponding to the start position.
If InStr(1, Join(arrRow, " "), strFilterWord, vbTextCompare) > 0 Then
'Test to see if the range to delete is empty or not
If rngToDelete Is Nothing Then
'If the range is empty, it is set to the first row to delete.
Set rngToDelete = rngCell.EntireRow
Else
'if the range is not empty, the row to delete is added to the range.
Set rngToDelete = Union(rngToDelete, rngCell.EntireRow)
End If
End If
Next rngCell
'After all cells are looped over, the rows to delete are deleted in one go
If Not rngToDelete Is Nothing Then rngToDelete.Delete
End With
End Sub

Answer 3

This should do the trick
Option Explicit
Sub DeletingRowContainingSpecificText()
Dim DataWorkSheet As Worksheet
'Change "ThisWorkBook" an "Sheet1" as you require
Set DataWorkSheet = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
Dim LastColumn As Long
With DataWorkSheet.UsedRange
LastRow = .Rows(.Rows.Count).Row
LastColumn = Columns(.Columns.Count).Column
End With
Dim word1 As String
word1 = InputBox("Enter a word by which you want to keep rows", "Enter")
Dim RowRange As Range
Dim RowReference As Long
Dim RowContent As String
Dim WordFound As Variant
'When ever you are deleting you need to start at the end and work your way back
'Otherwise the row after the row you deleted becomes the current row
For RowReference = LastRow To 22 Step -1
'Setting the Row Range from Column J to the end for a specific row
Set RowRange = ThisWorkbook.Worksheets("Sheet1").Range(Cells(RowReference, "J"), Cells(RowReference, LastColumn))
Set WordFound = RowRange.Find(What:=word1, LookIn:=xlValues)
If Not WordFound Is Nothing Then
'Choose if you want to delete or hidden
RowRange.EntireRow.Hidden = True
RowRange.EntireRow.Delete
End If
Next RowReference
End Sub
Just paste the Sub Content into your Button1_Click Sub. Otherwise paste this into your WorkBook Module and then test if it is working first.
I did test it and it worked for me.
NB when working with Deleting Rows or Columns always start at the end of the list and work your way to the beginning, this way the reference doesn't get messed up.

Answer 4

the problem resides in using Selection. You should avoid it at all costs!
If the data always is in the same region, this becomes quite simple. Try something like:
Sub Button1_Click()
Dim cell As Range
Dim rData as Range
'Assigns the range for J22 and adjacent rows and columns
Set rData = ActiveSheet.Range("J22").CurrentRegion
word1 = InputBox("Enter a word by which you want to keep rows", "Enter")
For Each cell In rData
If (InStr(1, cell, word1, 1) = 0) then cell.EntireRow.Delete
Next cell
End Sub
As you are not using Selection anymore, your 3 points get solved