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.
Related
I'm running into an issue where I'm unable to copy only visible cells to a new sheet. I'm able to get the lastrow, but I get #N/A on every cell except the first for each column. I want to just copy the visible cells. I'd also like to only put information on visible rows too, if possible?
Please see my code below:
Sub Importe()
lastRow = Worksheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
Worksheets.Add
With ActiveSheet
Range("A1:A" & lastRow).Value2 = _
ActiveWorkbook.Worksheets("Sheet1").Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Value
Range("B1:B" & lastRow).Value2 = _
ActiveWorkbook.Worksheets("Sheet1").Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Value
End With
End Sub
Something like .Value2 = .Value doesn't work on special cells of type visible, because …
… e.g. if lastRow = 50 and there are hiddenRows = 10 then …
your source Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible)
has lastRow - hiddenRows = 40 rows
but your destination Range("A1:A" & lastRow).Value2
has lastRow = 50 rows.
On the first you subtract the visible rows, so they are different in size. Therefore .Value2 = .Value doesn't work, because you cannot fill 50 rows with only 40 source rows.
But what you can do is Copy and SpecialPaste
Option Explicit
Sub Importe()
Dim lastRow As Long
lastRow = Worksheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
Worksheets.Add
With ActiveSheet
ActiveWorkbook.Worksheets("Sheet1").Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy
.Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.Worksheets("Sheet1").Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Copy
.Range("B1").PasteSpecial xlPasteValues
End With
End Sub
Nevertheless I recommend to avoid ActiveSheet or ActiveWorkbook if this is possible and reference a workbook eg by ThisWorkbook. My suggestion:
Option Explicit
Sub Importe()
Dim SourceWs As Worksheet
Set SourceWs = ThisWorkbook.Worksheets("Sheet1")
Dim DestinationWs As Worksheet
Set DestinationWs = ThisWorkbook.Worksheets.Add
Dim lastRow As Long
lastRow = SourceWs.Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
SourceWs.Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy
DestinationWs.Range("A1").PasteSpecial xlPasteValues
SourceWs.Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Copy
DestinationWs.Range("B1").PasteSpecial xlPasteValues
End Sub
To define whether a cell is visible or not, both its column and row should be visible. This means, that the .Hidden property of the column and the row should be set to False.
Here is some sample code of how to copy only the visible ranges between two worksheets.
Imagine that you have an input like this in Worksheets(1):
Then you manually hide column B and you want to get in Worksheets(2) every cell from the Range(A1:C4), without the ones in column B. Like this:
To do this, you should check each cell in the range, whether its column or row is visible or not.
A possible solution is this one:
Sub TestMe()
Dim myCell As Range
For Each myCell In Worksheets(1).Range("A1:C4")
If (Not Rows(myCell.Row).Hidden) And (Not Columns(myCell.Column).Hidden) Then
Dim newCell As Range
Set newCell = Worksheets(2).Cells(myCell.Row, myCell.Column)
newCell.Value2 = myCell.Value2
End If
Next myCell
End Sub
Just a general advise - whenever you use something like this Range("A1").Value2 = Range("A1").Value2 make sure that both are the same and not the left is Value2 and the right is .Value. It probably will not bring what you are expecting.
You cannot perform a direct value transfer without cycling though the areas of the SpecialCells(xlCellTypeVisible) collection.
Sometimes it is easier to copy everything and get rid of what you don't want.
Sub Importe()
Dim lr As Long
Worksheets("Sheet1").Copy after:=Worksheets("Sheet1")
With ActiveSheet
.Name = "xyz"
.Cells(1, 1).CurrentRegion = .Cells(1, 1).CurrentRegion.Value2
For lr = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
If .Cells(lr, "A").EntireRow.Hidden Then
.Cells(lr, "A").EntireRow.Delete
End If
Next lr
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(1, 1).CurrentRegion.Resize(lr, 1) = .Cells(1, 1).CurrentRegion.Resize(lr, 1).Offset(0, 7).Value2
.Cells(1, 1).CurrentRegion.Offset(0, 1).Resize(lr, 1) = .Cells(1, 1).CurrentRegion.Resize(lr, 1).Offset(0, 4).Value2
.Columns("C:XFD").EntireColumn.Delete
End With
End Sub
just to throw in an alternative version:
Sub Importe()
Dim sht1Rng As Range, sht1VisibleRng As Range
With Worksheets("Sheet1")
Set sht1Rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
End With
Set sht1VisibleRng = sht1Rng.SpecialCells(xlCellTypeVisible)
With Worksheets.Add
.Range("A1").Resize(sht1Rng.Rows.Count).Value2 = sht1Rng.Offset(, 7).Value2
.Range("B1").Resize(sht1Rng.Rows.Count).Value2 = sht1Rng.Offset(, 4).Value2
.UsedRange.EntireRow.Hidden = True
.Range(sht1VisibleRng.Address(False, False)).EntireRow.Hidden = False
End With
End Sub
which may have the drawback of Address() maximum "capacity "
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
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
I have two sheets containing the employee records.
Sheet1 contains the Event Date, CardNo, Employee Name, Dept Id, Employee No, Entry and Exit Time, Total Working Hours, Status, ConcatinatedColumn and Remarks (copied through vlookup from sheet2)
Sheet2 contains ConcatinatedColumn, Event Date, Employee No, Name, Remarks.
If the data in the remarks column of sheet2 is "Sick Off" then that row should be inserted to sheet1 without effecting the previous records.
I've already written the code for it but it does not work.
Would be really grateful if anyone can help me out !
THANKS IN ADVANCE !
MY CODE :
Sub SickOff()
Dim objWorksheet As Sheet2
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Sheet1
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Worksheets("Sheet2")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("G2:G" & objWorksheet.Cells(Rows.Count, "G").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells
objWorksheet.Select
If rngCell.Value = "Sick Off" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
Let's say you have data in Sheet2 as shown below
Let's say the end of data in Sheet1 looks like this
Logic:
We are using autofilter to get the relevant range in Sheet2 which match Sick Off in Col G. Once we get that, we copy the data to the last row in Sheet1. After the data is copied, we simply shuffle data across to match the column headers. As you mentioned that the headers won't change so we can take the liberty of hardcoding the column names for shuffling this data.
Code:
Paste this code in a module
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long, wsOlRow As Long, OutputRow As Long
Dim copyfrom As Range
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> This is the row where the data will be written
OutputRow = wsI.Range("A" & wsI.Rows.Count).End(xlUp).Row + 1
With wsO
wsOlRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter G on "Sick Off"
With .Range("G1:G" & wsOlRow)
.AutoFilter Field:=1, Criteria1:="=Sick Off"
Set copyfrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
If Not copyfrom Is Nothing Then
copyfrom.Copy wsI.Rows(OutputRow)
'~~> Shuffle data
With wsI
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & OutputRow & ":A" & lRow).Delete Shift:=xlToLeft
.Range("F" & OutputRow & ":F" & lRow).Copy .Range("K" & OutputRow)
.Range("F" & OutputRow & ":F" & lRow).ClearContents
.Range("B" & OutputRow & ":B" & lRow).Copy .Range("E" & OutputRow)
.Range("B" & OutputRow & ":B" & lRow).ClearContents
End With
End If
End Sub
Output:
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
...