I have a sheet where in Col A there is a String A and Col B consists of String B.
I want to keep rows with the Word 'Begründung' in Col A and 'Nein' in Col B.
I am using the following code found from these sources Efficient way to delete entire row if cell doesn't contain '#' & Delete Row based on Search Key VBA
Sub KeepOnlyAtSymbolRows()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("A1:A" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*Begründung*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
I want to add another criteria for the Col B. Wherever in Col B 'Nein' is encountered that row is kept and the rest is deleted but at the same time 'Begrüundung in Col A is kept and the rest is deleted.
In other words wherever the words 'Begründung' and 'Nein' is encountered in the sheet those rows are kept and the rest is deleted.
I would really be grateful if any of you could help.
Try this:
Sub DeleteWithMultipleColumnsCriterias()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("A1:B" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*Begründung*"
.AutoFilter Field:=2, Criteria1:="<>*Nein*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
Related
I'm trying to create a for loop for the code below.
The list of account as below:
[]
For Each Account In Accounts
With Range("A1", "K" & lngLastRow)
.AutoFilter
.AutoFilter Field:=1, Criteria1:=Account
.Copy OKSheet.Range("A1")
.AutoFilter
End With
Sheets("Summary").Select
Range("A1").Select
Selection.End(xlDown).Offset(2, 0).Select
Next Accounts
So without further info lets have a look at what could be changed with respect to what you have posted:
1) I can't see your variable declarations so i don't know how, and whether, you declared your variables, nor if you have Option Explicit at the top. So you could be getting errors such as Type mismatch or Application-defined or Object-defined error. We don't know as you don't state.
2) With Range("A1", "K" & lngLastRow) We don't know how you have calculated lngLastRow so this might terminate prematurely due to empty cells in a column.
It also implicitly references the Activesheet as isn't fully qualified as a range.
3) For Each Account In Accounts We don't know the variables types here so this might cause a type mismatch error, for example. I am unsure if Accounts, is meant to be a Range or a Named Range (or something else, possibly an Array)?
4) .Copy OKSheet.Range("A1") Inside a loop, without incrementing in some way, you will overwrite cell A1 with the contents of the filter at the current loop iteration. Meaning, you will end up with whatever the last filter criteria was in cell A1 in the destination sheet.
5) 1st .AutoFilter You clear the filter at the end of each loop so this may be redundant, depends on whether range is already filtered at start of loop.
6) The following three lines, within the loop, i think are redundant, as they don't actually do anything (except potentially produce an error) since your loop is over a defined range (Definitely a collection object or Array, we hope) and you will be returning to the next element.
Sheets("Summary").Select
Range("A1").Select
Selection.End(xlDown).Offset(2, 0).Select
And even if it were not looping to a specified range, you don't functionally achieve anything with these steps that couldn't be done with a single cell selection outside of the loop.
The following
Sheets("Summary").Select
As one should avoid .Select, where possible, could become
Sheets("Summary").Activate
if there is not something in cell A2, or beyond, then the following line has taken us to the land of Application defined or object defined error by trying to jump off the end of the spreadsheet.
Selection.End(xlDown).Offset(2, 0).Select
Selection.End(xlDown) has taken us to the last row in the sheet and then there is an attempt to offset a further two rows.
You could use (and i suspect outside of the loop)
Sheets("Summary").Cells(Sheets("Summary").Rows.Count, "A").End(xlUp).Offset(2, 0).Activate
With that in mind
With Accounts as a Range object code might look like:
Option Explicit
Public Sub TEST()
Dim Accounts As Range 'Variable declarations
Dim Account As Range
Dim wb As Workbook
Dim wsSource As Worksheet
Dim OKSheet As Worksheet
Set wb = ThisWorkbook 'Variable assignments
Set wsSource = wb.Worksheets("Sheet1")
Set OKSheet = wb.Worksheets("Sheet2")
Dim lngLastRow As Long
Dim nextOKRow As Long
lngLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row 'find last row by coming from the bottom of the sheet and finding last used cell in column
Set Accounts = wsSource.Range("A1:A" & lngLastRow) 'define Accounts
For Each Account In Accounts
nextOKRow = OKSheet.Cells(OKSheet.Rows.Count, "A").End(xlUp).Row 'increment where you paste
If nextOKRow > 1 Then nextOKRow = nextOKRow + 1
With wsSource.Range("A1:K" & lngLastRow) 'fully qualify range 'could also have as With wsSource.Range("A1", "K" & lngLastRow)
.AutoFilter 'redundant?
.AutoFilter Field:=1, Criteria1:=Account
.Copy OKSheet.Range("A" & nextOKRow) 'here you were just pasting over the same cell each time
.AutoFilter
End With
' Sheets("Summary").Range("A1").Activate
'Selection.End(xlDown).Offset(2, 0).Select ' off the sheet. 'not actually doing anything as you revisit the next Account range
Next Account
''Potentially uncomment the following two lines
'Sheets("Summary").Activate
'Sheets("Summary").Cells(Sheets("Summary").Rows.Count, "A").End(xlUp).Offset(2, 0).Activate
End Sub
With Accounts as a Named Range:
Public Sub TEST2()
Dim Account As Range
Dim wb As Workbook
Dim wsSource As Worksheet
Dim OKSheet As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet1")
Set OKSheet = wb.Worksheets("Sheet2")
Dim lngLastRow As Long
Dim nextOKRow As Long
lngLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
wsSource.Range("A1:A" & lngLastRow).Name = "Accounts"
For Each Account In wb.Names("Accounts").RefersToRange
nextOKRow = OKSheet.Cells(OKSheet.Rows.Count, "A").End(xlUp).Row
If nextOKRow > 1 Then nextOKRow = nextOKRow + 1
With wsSource.Range("A1:K" & lngLastRow)
.AutoFilter
.AutoFilter Field:=1, Criteria1:=Account
.Copy OKSheet.Range("A" & nextOKRow)
.AutoFilter
End With
Next Account
End Sub
With Accounts as an Array:
Public Sub TEST3()
Dim Accounts() 'Variable declarations
Dim Account As Variant
Dim wb As Workbook
Dim wsSource As Worksheet
Dim OKSheet As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet1")
Set OKSheet = wb.Worksheets("Sheet2")
Dim lngLastRow As Long
Dim nextOKRow As Long
lngLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
Accounts = wsSource.Range("A1:A" & lngLastRow).Value
For Each Account In Accounts
nextOKRow = OKSheet.Cells(OKSheet.Rows.Count, "A").End(xlUp).Row
If nextOKRow > 1 Then nextOKRow = nextOKRow + 1
With wsSource.Range("A1:K" & lngLastRow)
.AutoFilter
.AutoFilter Field:=1, Criteria1:=Account
.Copy OKSheet.Range("A" & nextOKRow)
End With
Next Account
End Sub
I have some code that deletes every row that doesn't contain a key string (in this case "2550"). The issue is, if I run the script twice by mistake, it will delete the top row in the worksheet.
See the code below:
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets(1)
lastRow = ws.Range("L" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("L1:L" & lastRow)
With rng
.AutoFilter Field:=1, Criteria1:="<>*2550*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.AutoFilterMode = False
I thought that if there was no row with that key, the AutoFilter would show nothing and therefore nothing should be deleted, but it appears that that is not the case. Could anyone explain why that may be?
Another solution is to use the Max function in your last row declaration. Something like:
lastRow = Application.Max(2,ws.Range("L" & ws.Rows.Count).End(xlUp).Row)
Allows you to skip some nesting and IF statements.
Put in a test..
lastRow = ws.Range("L" & ws.Rows.Count).End(xlUp).Row
If lastRow = 1 Then
Set rng = ws.Range("L1:L" & lastRow)
With rng
.AutoFilter Field:=1, Criteria1:="<>*2550*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.AutoFilterMode = False
End If
If lastRow returns the top row, it won't do the rest.
I have a combo box with a value that I would like to be searched for in another workbook column. The code using autofilter then returns the rows which have that value in the same column(column 4).
It works correctly however the first row of the source is always being copied over to the destination, weather it does or doesn't not have the value being looking for in the specific column.
The offset or cell shifting is being used as the first two row in both sheets are headers
Sub CommandButton1_Click()
'Look in data repository for the Combobox filter value and only return those associated rows (can be more than one)
Dim DataBlock As Range, Dest As Range
Dim LastRow As Long, LastCol As Long
Dim SheetOne As Worksheet, SheetTwo As Worksheet
Dim PN As String
PN = ComboBox1.Value
'set references up-front
Set SheetTwo = ThisWorkbook.Worksheets("Report") 'this is the expiditing report
Set SheetOne = Workbooks.Open("C:\Users\Colin\Documents\Nexen\Data Repository V1.xlsm").Sheets("Data") 'this is the expiditing report
Set Dest = SheetTwo.Cells(3, 1) '<~ this is where we'll put the filtered data
'identify the "data block" range, which is where
'the rectangle of information that Ill apply
'.autofilter to
With SheetOne
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set DataBlock = .Range(.Cells(3, 1), .Cells(LastRow, LastCol))
'Set DataBlock = Range("A3:AV65000") 'for testing
End With
'apply the autofilter to column D (i.e. column 4)
With DataBlock
'can use offset .Offset(2, 0).
.AutoFilter Field:=4, Criteria1:=PN
'copy the still-visible cells to sheet 2
.SpecialCells(xlCellTypeVisible).Copy Destination:=Dest
End With
'turn off the autofilter
With SheetOne
.AutoFilterMode = False
If .FilterMode = True Then .ShowAllData
End With
End Sub
Sub CommandButton2_Click()
Dim MyBook As String
Dim MyRange As Range
'Get name of current wb
MyBook = ThisWorkbook.Name
Set MyRange = MyBook.Sheets("Report").Range("T3,AC65000")
'ActiveWorkbook.Close savechanges:=True
MyBook.Activate
End Sub
![etr][1]
So why am i getting the first row back regardless? I have tried a multitude of things.
Your .Range needs to be in a Table with a header for AutoFilter to work properly.
I am trying to write a macro in vba for excel. I want to delete every row that does not have at least one of three keywords in column D (keywords being "INVOICE", "PAYMENT", or "P.O."). I need to keep every row that contains these keywords. All other rows need to be deleted and the rows remaining need to be pushed to the top of the document. There are also two header rows that can not be deleted.
I found the code below but it deletes every row that does not contain "INVOICE" only. I can not manipulate the code to do what I need it to do.
Sub Test()
Dim ws As Worksheet
Dim rng1 As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("*Name of Worksheet")
lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("D1:D" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="<>*INVOICE*"
.Offset(2, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
I would approach this loop slightly different. To me this is a bit easier to read.
Sub Test()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim value As String
Set ws = ActiveWorkbook.Sheets("*Name of Worksheet")
lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
' Evaluate each row for deletion.
' Go in reverse order so indexes don't get messed up.
For i = lastRow To 2 Step -1
value = ws.Cells(i, 4).Value ' Column D value.
' Check if it contains one of the keywords.
If Instr(value, "INVOICE") = 0 _
And Instr(value, "PAYMENT") = 0 _
And Instr(value, "P.O.") = 0 _
Then
' Protected values not found. Delete the row.
ws.Rows(i).Delete
End If
Next
End Sub
The key here is the Instr function which checks for your protected keywords within the cell value. If none of the keywords are found then the If condition is satisfied and the row is deleted.
You can easily add additional protected keywords by just appending to the If conditions.
'similar with previous post, but using "like" operator
Sub test()
Dim ws As Worksheet, i&, lastRow&, value$
Set ws = ActiveWorkbook.ActiveSheet
lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
value = ws.Cells(i, 4).value
' Check if it contains one of the keywords.
If Not (value Like "*INVOICE*" _
Or value Like "*PAYMENT*" _
Or value Like "*P.O.*") _
Then
' Protected values not found. Delete the row.
ws.Rows(i).Delete
End If
Next
End Sub
'
Sub test()
Dim i&
Application.ScreenUpdating = False
i = Range("D" & Rows.Count).End(xlUp).Row
While i <> 1
With Cells(i, 4)
If Not (.value Like "*INVOICE*" _
Or .value Like "*PAYMENT*" _
Or .value Like "*P.O.*") _
Then
Rows(i).Delete
End If
End With
i = i - 1
Wend
Application.ScreenUpdating = True
End Sub
The othe way is to insert an IF test in a working column, and then AutoFilter that.
This is the VBA equivalent of entering
=SUM(COUNTIF(D1,{"*INVOICE*","*PAYMENT*","*P.O.*"}))=0
and then deleting any row where none of these values are found in the corrresponing D cell
Sub QuickKill()
Dim rng1 As Range, rng2 As Range, rng3 As Range
Set rng1 = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious)
Set rng2 = Cells.Find("*", , xlValues, , xlByRows, xlPrevious)
Set rng3 = Range(Cells(rng2.Row, rng1.Column), Cells(1, rng1.Column))
Application.ScreenUpdating = False
Rows(1).Insert
With rng3.Offset(-1, 1).Resize(rng3.Rows.Count + 1, 1)
.FormulaR1C1 = "=SUM(COUNTIF(RC[-1],{""*INVOICE*"",""*PAYMENT*"",""*P.O.*""}))=0"
.AutoFilter Field:=1, Criteria1:="TRUE"
.EntireRow.Delete
On Error Resume Next
'in case all rows have been deleted
.EntireColumn.Delete
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub
How do you find the last row of data when the data in your worksheet is filtered? I have been playing around with Special Cells and Visible Cells but cannot find a solution. I think it must be some kind of variation on what I have below:
...
With ws
LR = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:E" & LR).AutoFilter Field:=2, Criteria1:="=4"
LRfilt = .Range("A" & Rows.SpecialCells(xlCellTypeVisible).Count).End(xlUp).Row
Debug.Print LR
Debug.Print LRfilt
End With
...
File can be found here:
wikisend.com/download/443370/FindLRFilteredData.xls
Edit:
Realised after discussion with Siddharth I did not want the Last Row property I needed to find a count of the number of visible rows which led on to Sid's solution below...
After the filter, using the same formula for the lastrow will return the last filtered row:
...
With ws
LR = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:E" & LR).AutoFilter Field:=2, Criteria1:="=4"
LRfilt = .Range("A" & Rows.Count).End(xlUp).Row
Debug.Print LR
Debug.Print LRfilt
End With
...
EDIT: Post Chat Followup
Option Explicit
Sub FilterTest()
Dim rRange As Range, fltrdRng As Range, aCell As Range, rngToCopy As Range
Dim ws As Worksheet
Dim LR As Long
'~~> Change this to the relevant sheet
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Sheet1" Then
With ws
'~~> Remove any filters
.AutoFilterMode = False
LR = .Range("A" & Rows.Count).End(xlUp).Row
'~~> Change this to the relevant range
Set rRange = .Range("A1:E" & LR)
With rRange
'~~> Some Filter. Change as applicable
.AutoFilter Field:=2, Criteria1:=">10"
'~~> Get the filtered range
Set fltrdRng = .SpecialCells(xlCellTypeVisible)
End With
For Each aCell In fltrdRng
If aCell.Column = 1 Then
If rngToCopy Is Nothing Then
Set rngToCopy = aCell
Else
Set rngToCopy = Union(rngToCopy, aCell)
End If
End If
Next
Debug.Print ws.Name
Debug.Print rngToCopy.Address
'rngToCopy.Copy
Set rngToCopy = Nothing
'~~> Remove any filters
.AutoFilterMode = False
End With
End If
Next
End Sub
Assuming your data is already filtered, you can try this:
Range("A1").Select
Dim FinalRowFiltered as Long
Dim FR as as String
FinalRowFiltered = Range("A" & Rows.Count).End(xlUp).Row
FR = "A" & CStr(FinalRowFiltered)
Range(FR).Select
After a lot of researching, came up with different options and I put some of them together which seems to be working fine for me (I made it work in a Table):
Hope you find it useful.
ActiveSheet.ListObjects("Table").Range.SpecialCells(xlCellTypeVisible).Select
b = Split(Selection.Address, "$")
iRes = UBound(b, 1)
If iRes = -1 Then
iRes = 0
End If
LastRow = Val(b(iRes))
This seems to work. When filters are on the normal .end(xlUp) gives the last row of a filtered range, but not the last row of the sheet. I suggest you use this technique to get the last row:
Sub GetLastRow
' Find last row regardless of filter
If Not (ActiveSheet.AutoFilterMode) Then ' see if filtering is on if already on don't turn it on
Rows(1).Select ' Select top row to filter on
Selection.AutoFilter ' Turn on filtering
End if
b = Split(ActiveSheet.AutoFilter.Range.Address, "$") ' Split the Address range into an array based on "$" as a delimiter. The address would yeild something like $A$1:$H$100
LastRow= Val(b(4)) ' The last value of the array will be "100" so find the value
End sub
This is simplest solution
...
With ws
.Range("A1:E1").AutoFilter Field:=2, Criteria1:="=4"
LRfilt=.Range("A1", .Range("A1").End(xlDown)).End(xlDown).Row
Debug.Print LRfilt
End With
...