Exctract overdue items that are not closed

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

You might benefit from reading [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). • Also please give a full example data (see [mcve]) so we can more easily understand what exactly your issue is. Screenshots might help too. — Pᴇʜ, Aug 01 '19 at 11:23
I have detailed as much as possible. Unfortunately I cant find a way to upload sample file or screen shot — Prashant Poojari, Aug 01 '19 at 13:26

Warcupine · Answer 1 · 2019-08-02T13:24:08.080

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.

I did the change you have recommended. But the Code only generates 2 lines and then Exist. Any other change that you feel — Prashant Poojari, Aug 01 '19 at 13:25
I would try stepping through the code to see what is happening. It's kind of hard for me to tell what is happening with all the select, activate, and deletes in this code. — Warcupine, Aug 01 '19 at 13:55
Is there a simpler way to achieve the result. I am a novice and not into coding too much. Please forgive my code skills. Would appreciate if you could provide a better code — Prashant Poojari, Aug 02 '19 at 03:43
Let me clarify some stuff, you want to delete whats in ```sheets("Open Items")``` then copy anything in ```sheets("Observation Tracker)``` that is both open and the target date is greater than today's date into ```sheets("Open Items")```? — Warcupine, Aug 02 '19 at 12:05
The code works perfectly. I cant Thank you enough for helping me out on this one. As I mentioned I am learning coding and your explainations also helped me learn the changes. — Prashant Poojari, Aug 05 '19 at 04:05

Exctract overdue items that are not closed

1 Answers1