Excel ListObject Table - Remove filtered / hidden rows from ListObject table - vba

I am banging my head to find a way to delete filtered/hidden rows from a ListObject table.
The filtering is not performed trough the code, it's performed by the user using the table header filters. I want to remove the filtered/hidden rows before unlisting the ListObject Table and perform Subtotal operation. If I don't delete the filtered/hidden rows before unlisting the Table, these rows reappear.
Current Code :
Sub SubTotalParClassification(ReportSheetTitle)
Dim ws As Worksheet
Dim drng As Range
Endcol = ColCalculationEndIndex
Set ws = Sheets(ReportSheetTitle)
'CODE TO REMOVE HIDDEN/FILTERED ROWS
Set lo = ActiveSheet.ListObjects("Entrée")
For i = 1 To lo.ListRows.Count Step 1
If Rows(lo.ListRows(i).Range.Row).Hidden = True Then
lo.ListRows(i).Delete
Next
' convert the table back to a range to be able to build subtotal
ws.ListObjects("Entrée").Unlist
With ws
'Select range to Subtotal
Set drng = .Range(.Cells(REPORTHEADERROW, REPORTSSTARTCOL), .Cells(EndRow, Endcol))
'apply Excel SubTotal function
.Cells.RemoveSubtotal
drng.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(Endcol - 6, Endcol - 5, Endcol - 4, Endcol - 3, Endcol - 2, Endcol - 1)
End With
'Update EndRow
EndRow = ActiveSheet.Cells(Rows.Count, REPORTSSTARTCOL).End(xlUp).Row
End Sub

Unfortunately, the Range.SpecialCells method does not have a specific parameter for xlCellTypeInvisible, only one for xlCellTypeVisible. To collect all of the hidden rows we need to find the compliment of the .DataBodyRange property and the visible rows, not the Intersect. A short UDF can take care of that.
Once a Union of the hidden rows have been established you cannot simply delete the rows; you must cycle through the Range.Areas property. Each area will contain one or more contiguous rows and those can be deleted.
Option Explicit
Sub wqewret()
SubTotalParClassification "Sheet3"
End Sub
Sub SubTotalParClassification(ReportSheetTitle)
Dim a As Long, delrng As Range
With Worksheets(ReportSheetTitle)
With .ListObjects("Entrée")
'get the compliment of databody range and visible cells
Set delrng = complimentRange(.DataBodyRange, .DataBodyRange.SpecialCells(xlCellTypeVisible))
Debug.Print delrng.Address(0, 0)
'got the invisible cells, loop through the areas backwards to delete
For a = delrng.Areas.Count To 1 Step -1
delrng.Areas(a).EntireRow.Delete
Next a
End With
End With
End Sub
Function complimentRange(bdyrng As Range, visrng As Range)
Dim rng As Range, invisrng As Range
For Each rng In bdyrng.Columns(1).Cells
If Intersect(visrng, rng) Is Nothing Then
If invisrng Is Nothing Then
Set invisrng = rng
Else
Set invisrng = Union(invisrng, rng)
End If
End If
Next rng
Set complimentRange = invisrng
End Function
Remember that it is considered 'best practise' to start at the bottom and work towards the top when deleting rows.

Related

How to fix Compile Error: Sub or function not defined in VBA?

This is a code that goes through the cells in column B in sheet2. If it finds a value that is not a date in column B, then it copies it, pastes it another sheet called 'errors' and then deletes that row from Sheet2. Whenever I try to run this, however, I get a 'Compile Error: Sub or function not defined'. I saw some other posts on this, but nothing mentioned there seemed to work for me.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheet("Errors").CountA("A1:A100")
For Each i In Worksheet("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheet("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
There are a few other errors/changes that could be made within the script
Add s to Worksheet
Use Option Explicit at top of code
Application.WorksheetFunction.CountA
Add range as argument to Counta i.e. Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Ensure correct ranges being worked with by wrapping in With Worksheets("Sheet2")
Determine last row by coming up from bottom of sheet with .Cells(.Rows.Count, "A").End(xlUp).Row, or you could end up looping to bottom of sheet
Correct syntax for delete line: i.EntireRow.Delete
You can put copy paste on one line: .Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
Be wary of using End(xlToRight) in cases of potentially ending up at far right of sheet.
Optimize code by switching some things off e.g. prevent repaint by switching off screen-updating during looping
Gather ranges to delete with Union and delete in 1 go or loop backwards to delete
VBA:
Option Explicit
Public Sub removeerrors()
Dim i As Range, x As Double, loopRange As Range, lastRow As Long, unionRng As Range
x = Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Application.ScreenUpdating = False
With Worksheets("Sheet2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set loopRange = .Range("A2:A" & lastRow)
If lastRow = 1 Then Exit Sub
For Each i In loopRange
If Not IsDate(i.Offset(0, 1)) Then
.Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, i)
Else
Set unionRng = i
End If
End If
Next i
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
You just need to change Worksheet to Worksheets with 's' at the end.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
For Each i In Worksheets("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheets("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
use fully qualified range references
loop backwards when deleting rows
update target sheet pasting row index
as follows
Option Explicit
Sub removeerrors()
Dim iRow As Long
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
With Worksheets("Sheet2") ' referecne "Sheet2" sheet
With .Range(.Range("A2"), .Range("A2").End(xlDown)) ' reference referenced sheet range from cell A2 down to next not empty one
For iRow = .Rows.Count To 1 Step -1 ' loop reference range backwards from its last row up
If Not IsDate(.Cells(iRow, 2)) Then ' if referenced range cell in column B current row is not a date
.Range(.Cells(iRow, 1), .Cells(iRow, 1).End(xlToRight)).Copy Destination:=Worksheets("Errors").Range("A1").Offset(x, 0) ' copy referenced range current row spanning from column A to next not empty column and paste it to sheet "Errors" column A row x
x = x + 1 ' update offset
.Rows(1).EntireRow.Delete ' delete referenced range current row
End If
Next
End With
End With
End Sub

Get Filtered records into Array Variant without looping VBA

I have 10 records in excel of which i have edited 3rd and 7th records and placing a flag/string "modified" in certain column belongs to same rows to filter while processing
Below is the code that i am working with which is fetching only the first record(3rd) and not the 7th record into array using VBA
Dim RecordsArray() As Variant
Set sht = ThisWorkbook.Sheets("RMData")
sht.Range("M1:M100").AutoFilter Field:=1, Criteria1:="Modified"
sht.Range("A2:A100").Rows.SpecialCells (xlCellTypeVisible)
col = [a2].CurrentRegion.Columns.count
lw = [a2].End(xlDown).Row
RecordsArray = Range(Cells(2, 1), Cells(lw,col)).SpecialCells(xlCellTypeVisible)
Idea is I want to get those two records without looping and searching for
"Modified" string for the edited row
When reading a Filtered Range, most likely there will be splits ranges, the rows will not be continuous, so you need to loop through the Areas of the Filtered Range.
Also, you might have a few Rows in each Area, so you should loop through the Area.Rows.
More detailed comments in my code below.
Code
Option Explicit
Sub Populated2DArrayfromFilterRange()
Dim RecordsArray() As Variant
Dim sht As Worksheet
Dim col As Long, lw As Long, i As Long
Dim FiltRng As Range, myArea As Range, myRow As Range
ReDim RecordsArray(0 To 1000) ' redim size of array to high number >> will optimize later
' set the worksheet object
Set sht = ThisWorkbook.Sheets("RMData")
i = 0 ' reset array element index
' use With statement to fully qualify all Range and Cells objects nested inside
With sht
.Range("M1:M100").AutoFilter Field:=1, Criteria1:="Modified"
.Range("A2:A100").Rows.SpecialCells (xlCellTypeVisible)
col = .Range("A2").CurrentRegion.Columns.Count
lw = .Range("A2").End(xlDown).Row
' set the filtered range
Set FiltRng = .Range(.Cells(2, 1), .Cells(lw, col)).SpecialCells(xlCellTypeVisible)
' Debug.Print FiltRng.Address(0, 0)
For Each myArea In FiltRng.Areas ' <-- loop through areas
For Each myRow In myArea.Rows ' <-- loop through rows in area
RecordsArray(i) = Application.Transpose(Application.Transpose(myRow))
i = i + 1 ' raise array index by 1
Next myRow
Next myArea
ReDim Preserve RecordsArray(0 To i - 1) ' optimize array size to actual populated size
End With
End Sub
If you have a hidden row in the middle, then .SpecialCells(xlCellTypeVisible) will return multiple Areas. Assigning a range to an Array only assigns the first Area. (At also always makes the array 2D)
Instead of looping & searching for "Modified", you could just loop For Each cell in the SpecialCells range and assign that to the array instead - if you plan was "no loops at all" then this is not what you want. (But, I would then have to ask you "why not?"!)
Dim RecordsArray() As Variant, rFiltered As Range, rCell As Range, lCount As Long
Set sht = ThisWorkbook.Sheets("RMData")
sht.Range("M1:M100").AutoFilter Field:=1, Criteria1:="Modified"
sht.Range("A2:A100").Rows.SpecialCells (xlCellTypeVisible)
col = [a2].CurrentRegion.Columns.Count 'This will act on ActiveSheet, not sht - is that intended?
lw = [a2].End(xlDown).Row 'In case of gaps, would "lw=sht.Cells(sht.Rows.Count,1).End(xlUp).Row" be better?
'RecordsArray = Range(Cells(2, 1), Cells(lw, col)).SpecialCells(xlCellTypeVisible)
Set rFiltered = Range(Cells(2, 1), Cells(lw, col)).SpecialCells(xlCellTypeVisible)
ReDim RecordsArray(1 To rFiltered.Cells.Count, 1) 'Mimic default assignment
lCount = 1
For Each rCell In rFiltered
RecordsArray(lCount, 1) = rCell.Value
lCount = lCount + 1
Next rTMP
Set rCell = Nothing
Set rFiltered = Nothing
If you want to avoid dealing with the visible areas mentioned already, you can try something like this
Option Explicit
Public Sub CopyVisibleToArray()
Dim recordsArray As Variant, ws As Worksheet, nextAvailable As Range
Set ws = ThisWorkbook.Worksheets("RMData")
Set nextAvailable = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(2)
With ws.Range("M1:M100")
Application.ScreenUpdating = False
.AutoFilter Field:=1, Criteria1:="Modified"
If .Rows.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
'copy - paste visibles in col A, under all data
ws.UsedRange.Columns("A:M").SpecialCells(xlCellTypeVisible).Copy nextAvailable
Set nextAvailable = nextAvailable.Offset(1)
nextAvailable.Offset(-1).EntireRow.Delete 'Delete the (visible) header
recordsArray = nextAvailable.CurrentRegion 'Get the cells as array
nextAvailable.CurrentRegion.EntireRow.Delete 'Delete the temporary range
End If
.AutoFilter
Application.ScreenUpdating = True
End With
End Sub
To copy just column A to array use this: ws.UsedRange.Columns("A")
To copy columns A to M use this: ws.UsedRange.Columns("A:M")

Delete entire rows in excel sheet from a table using macro

i want to build a macro that delete rows from a table in an excel sheet based on an if statement that runs on all the rows from row number 2 to the end of the table - if the value in row i and column B equals 0 i would like to delete the entire row.
this is the code i wrote but nothing happens when i run it
Sub deleteZeroRows()
'loop for deleting zero rows
Dim wbCurrent As Workbook
Dim wsCurrent As Worksheet
Dim nLastCol, i As Integer
Set wbCurrent = ActiveWorkbook
Set wsCurrent = wbCurrent.ActiveSheet
Dim lastRow As Long
lastRow = Range("b2").End(xlDown).Select
For i = 2 To lastRow
If wsCurrent.Cells(i, 2) = 0 Then
wsCurrent.Cells(i, 2).EntireRow.Delete
End If
Next i
End Sub
A faster method to delete multiple rows from your worksheet is to store all the Rows that need to be deleted in a Range, using the Union function.
After you exit your For loop, just delete the entire rows DelRng at one command.
More notes in my code's comments below.
Code
Option Explicit '<-- always use this at the top of your code
Sub deleteZeroRows()
Dim wbCurrent As Workbook
Dim wsCurrent As Worksheet
Dim lastRow As Long, nLastCol As Long, i As Long
Dim DelRng As Range
Set wbCurrent = ActiveWorkbook '<-- try to avoid using Active...
Set wsCurrent = wbCurrent.ActiveSheet '<-- try to avoid using Active...
With wsCurrent
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row ' get last row in column B
For i = 2 To lastRow
If .Range("B" & i).Value = 0 Then
If Not DelRng Is Nothing Then
' add another row to DelRng range
Set DelRng = Application.Union(DelRng, .Rows(i))
Else
Set DelRng = .Rows(i)
End If
End If
Next i
End With
' if there's at least 1 row to be deleted >> delete all rows in DelRng at 1-line
If Not DelRng Is Nothing Then DelRng.Delete
End Sub
a "fast & furious" code:
Sub deleteZeroRows()
With Range("B2", Cells(Rows.Count, 2).End(xlUp)) 'reference column B cells from row 2 down to last not empty one
.Replace what:=0, lookat:=xlWhole, replacement:="" ' replace 0's with blanks
If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(XlCellType.xlCellTypeBlanks).EntireRow.Delete ' delete rows where referenced range is blank
End With
End Sub
which will also delete rows whose column B content is blank

Excel vba - multiple conditions and multiple statements

I am very new to VBA coding and need some help. I'm looking for a code that selects ranges based on the value of differet cells.
In my sheet i have 7 cells that have a formula which give the cell a "X" if i want an range is to be selected:
If I33 = "X" then select A1: S31 (I33 has a formula)
If I34 = "X" then select T1: AH31 (I33 has a formula)
I have 7 of these ....
What I'm looking for; if one or more of I33, I34, i35, I36, I37, I38 or I39 has an "X", the respective area (example A1:S31, there are 7 different ranges) should be selected.
Thanks for any help :-)
you can try this
Option Explicit
Sub main()
Dim xRangeAdress As Range, rangesAddress() As Range, rangeToSelect As Range, cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("X-Sheet") '<== change it as per your actual sheet name
Set xRangeAdress = ws.Range("I33:I39") '<== set the range with "X" formulas: change "I33:I39" as per your actual needs
Call SetRangeAddresses(rangesAddress(), ws) ' call the sub you demand the addresses settings to
For Each cell In xRangeAdress 'loop through "X" cells
If UCase(cell.Value) = "X" Then Set rangeToSelect = MyUnion(rangeToSelect, rangesAddress(cell.Row - 33 + 1)) ' if there's an "X" then update 'rangeToSelect' range with corresponding range
Next cell
rangeToSelect.Select
End Sub
Sub SetRangeAddresses(rangeArray() As Range, ws As Worksheet)
ReDim rangeArray(1 To 7) As Range '<== resize the array to as many rows as cells with "X" formula
With ws ' type in as many statements as cells with "X" formula
Set rangeArray(1) = .Range("A1:S31") '<== adjust range #1 as per your actual needs
Set rangeArray(2) = .Range("T1:AH31") '<== adjust range #2 as per your actual needs
Set rangeArray(3) = .Range("AI1:AU31") '<== adjust range #3 as per your actual needs
Set rangeArray(4) = .Range("AU1:BK31") '<== adjust range #4 as per your actual needs
Set rangeArray(5) = .Range("BL1:BT31") '<== adjust range #5 as per your actual needs
Set rangeArray(6) = .Range("BU1:CD31") '<== adjust range #6 as per your actual needs
Set rangeArray(7) = .Range("CE1:CJ31") '<== adjust range #7 as per your actual needs
End With
End Sub
Function MyUnion(rng1 As Range, rng2 As Range) As Range
If rng1 Is Nothing Then
Set MyUnion = rng2
Else
Set MyUnion = Union(rng1, rng2)
End If
End Function
I added comments to let you study and develop his code for your further knowledge
Just to have a different solution (regarding what you need choose one of them):
Option Explicit
Function MainFull(Optional WS As Variant) As Range
If VarType(WS) = 0 Then
Set WS = ActiveSheet
ElseIf VarType(WS) <> 9 Then
Set WS = Sheets(WS)
End If
With WS
Dim getRng As Variant, outRng As Range, i As Long
getRng = WS.Range("I33:I39").Value
For i = 1 To 7
If getRng(i, 1) = "x" Then
If MainFull Is Nothing Then
Set MainFull = .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1)) '<- change it to fit your needs
Else
Set MainFull = Union(MainFull, .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1))) '<- change it to fit your needs
End If
End If
Next
End With
End Function
Function MainArray(Optional WS As Variant) As Variant
If VarType(WS) = 0 Then
Set WS = ActiveSheet
ElseIf VarType(WS) <> 9 Then
Set WS = Sheets(WS)
End If
With WS
Dim getRng As Variant, outArr() As Variant, i As Long, j As Long
getRng = WS.Range("I33:I39").Value
i = Application.CountIf(WS.Range("I33:I39"), "x")
If i = 0 Then Exit Function
ReDim outArr(1 To i)
For i = 1 To 7
If getRng(i, 1) = "x" Then
j = j + 1
Set outArr(j) = .Range(Array("A1:S31", "T1:AL31", "AM1:BE31", "BF1:BX31", "BY1:CQ31", "CR1:DJ31", "DK1:EC31")(i - 1)) '<- change it to fit your needs
End If
Next
End With
MainArray = outArr
End Function
MainFull returns the whole range for all marked ranges while MainArray returns an array which holds all ranges which are marked with "x".
How to use it:
For MainFull you can simply set the range via Set myRange = MainFull("Sheet1"). This way it can easily used within another macro (sub) to copy/paste it somewhere.
But if you need to repeat this process for every set range (which is marked by "x") then the second sub is needed like:
Dim myRange As Variant
For Each myRange In MainArray("Sheet1")
....
Next
Then do all the stuff via myRange. If you still have any questions, just ask ;)

Deleting or keeping multiple rows by a specific word content

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.
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
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
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.
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