Exctract overdue items that are not closed - excel

Question

I have a Workbook in which there is a sheet named "tracker" that shows certain actionables that need to be closed by team member by target date. I can do it on excel using filters. But I tried ti build a VBA code to automate the process which is
Search for Status of action in column 28. If it is "Open" then Check if "target date" in column 43 is exited as of today. I put today date in column 46. If Target date is exceeded then I want that row to be copy pasted in another worksheet "Open Items". The code should move to next item in 2 situations, either the status is "closed" of Target date is yet to arrive.
Following is code I wrote. The code is executed properly but I get only the last row as output in Open items sheet. The code do not seem to check for status or dates properly
Sub OpenItems()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("Open Items").Select
Cells.Select
'Range("E16").Activate
Selection.Delete Shift:=xlUp
Sheets("Observation Tracker").Select
Range("A2").Select
Sheets("Observation Tracker").Activate
Lastrow = Cells(Rows.Count, "AQ").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets("Observation Tracker").Cells(Rows.Count,"AU").End(xlUp).Row + 1
For i = 2 To Lastrow
If Cells(i, 28).Value = "Open" Then
If Cells(i, 43).Value < Cells(i, 46).Value Then
Rows(i).Copy Sheets("Open items").Rows(Lastrow)
i = i + 1
End If
End If
Next
Sheets("Observation Tracker").Select
Rows("1:1").Select
Selection.Copy
Sheets("Open Items").Select
Range("AI1").Select
Selection.End(xlToLeft).Select
ActiveSheet.Paste
Range("A1").Select
MsgBox "Open Items Extracted"
Application.ScreenUpdating = True
End Sub
I want all open items with dates passed by to populate in the Open Item worksheet

Answer 1

This line here Rows(i).Copy Sheets("Open items").Rows(Lastrow) will always paste to the same row because you never increment lastrow. So as your code loops through the sheet the output is constantly being overwritten until the last match is made which is the only one you will see.
Rows(i).Copy Sheets("Open items").Rows(Lastrow)
lastrow = lastrow + 1
I don't think you need i = i + 1 either because your for loop is already incrementing i so you are skipping a line every time it gets there.
EDIT:
Here is what I came up with.
Sub OpenItems()
Dim i As Long
Dim lastrow As Long
Dim lastcol As Long
Dim pasteiter As Long
Application.ScreenUpdating = False
With Sheets("Open Items")
'This will clear the contents of Open Items
lastrow = .Cells(Rows.Count, 43).End(xlUp).Row
lastcol = .Cells.Find(What:="*", after:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
.Range(.Cells(2, 1), .Cells(lastrow, lastcol)).ClearContents
End With
pasteiter = 2 'Make sure we don't overwrite anything
With Sheets("Observation Tracker")
lastrow = .Cells(Rows.Count, "AQ").End(xlUp).Row
For i = 2 To lastrow
'Combined the two IF statements since we weren't using the outer else.
If (.Cells(i, 28).Value = "Open") And (.Cells(i, 43).Value <= .Cells(i, 46).Value) Then
.Rows(i).Copy Sheets("Open Items").Rows(pasteiter)
pasteiter = pasteiter + 1
End If
Next
.Rows(1).Copy Sheets("Open Items").Rows(1) 'Grab the headers
End With
Application.ScreenUpdating = True
MsgBox "Open Items Extracted"
'I'm not sure what your last bits of code did I removed them.
End Sub
If open items sheet is blank just put something in the first row the first time you run this otherwise you will get a with/object error. Should only occur the first time though.
I removed all your selections and activates, they aren't necessary, slow things down, and obfuscate your code. I also removed lastrowa as it didn't appear to be used.