VBA - Move row(s) based on column cell value

[DavetheScot58]

I am trying to move a row from one worksheet (Active opportunities) to a second worksheet (Archived opportunities) based on whether date(s) entered in column I are up to and including today's date. These dates in column I are forecast archival dates entered in the original worksheet sometimes months in advance. I need the VBA to move the row entry when these archive dates are reached, also, if I don't access the workbook for any period of time, a number of dates may have expired so I need the VBA to check all archived dates up to and including today's date, move the row entries to the archived worksheet and delete the now empty row(s) on the original worksheet. I have entered this in ThisWorkbook so that it starts whenever I open the workbook containing the two worksheets.

As a non-VBA practitioner, I have tried to create this VBA code based on others postings but find that it does not search column I for dates up to and including today's date. Any help would be greatly appreciated.

Private Sub Workbook_Open()
Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
Application.ScreenUpdating = False
lastrow = Worksheets("Active Opportunities").UsedRange.Rows.Count
lastrow2 = Worksheets("Filed Opportunities").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = lastrow To 2 Step -1
If Range("I" & r).Value <= Date Then
Rows(r).Cut Destination:=Worksheets("Filed Opportunities").Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
Else:
End If
Next r
Application.ScreenUpdating = True
End Sub

 

[Scott T]

In your post you said the sheet name was Archived opportunities but your code had Filed Opportunities. I used Archived opportunities change as need.

Private Sub Workbook_Open()
Dim act As Worksheet
Dim arch As Worksheet
Dim lract As Long
Dim lrarch As Long

Application.ScreenUpdating = False
Set act = Sheets("Active opportunities")
Set arch = Sheets("Archived opportunities")
lract = act.Cells(Rows.Count, "I").End(xlUp).Row 'last row in active oportuniies sheet

For x = 2 To lract
    If act.Cells(x, 9) <= Date Then
        lrarch = arch.Cells(Rows.Count, 9).End(xlUp).Row 'last row in archived opportunities sheet
        Rows(x).EntireRow.Cut Destination:=arch.Range("A" & lrarch + 1)
        Application.CutCopyMode = False
        Rows(x).EntireRow.Delete
    End If

Next x

Application.ScreenUpdating = True

End Sub

 

[DavetheScot58]

Thank you for this however I can't run the code as it stops at a certain point. My fault as I did not explain that some rows have column A, B and C entries merged. I will try to replicate below. Problem appears to occur at - Rows(x).EntireRow.Cut Destination:=arch.Range("A" & lrarch + 1).

A B C D E .......... I
_________________________________________________________________
| | |__Time 1_|__Bill___|_Date 1_|____________________
3 | 9 | 17 |__Time 2_|__Fred__|_Date 2_|____________________
____|______|________|_Time 3__|__Joe___|_Date 3_|____________________

 

[Scott T]

Mereged cells should be avoid if because it prevents you form doing things like this. Not sure what can be done besides unmerging the cells.

 

[Michael M]

You will need to Unmerge the cells......
My spin after the above task is done is...

Private Sub Workbook_Open()
Dim r As Long, lastrow2 As Long, lastrow As Long
Application.ScreenUpdating = False
lastrow = Worksheets("Active Opportunities").UsedRange.Rows.Count
lastrow2 = Worksheets("Filed Opportunities").UsedRange.Rows.Count
    For r = lastrow To 2 Step -1
        If Range("I" & r).Value <= Date Then
            Rows(r).Copy Worksheets("Filed Opportunities").Range("A" & lastrow2 + 1)
            lastrow2 = lastrow2 + 1
            Rows(r).Delete
        End If
    Next r
Application.ScreenUpdating = True
End Sub