Move entire row based on expiration date

[nmccracken12]

I am trying to get this code to work that I found on here. I am able to change the sheet names, but I am not knowledgeable enough to know how to change the cells that matter. Code below. The expiration date sits in column I. The columns in play are A-I. Any one able to help? Thanks in advance!

Sub TransferExpired()
Dim c As Range, TransferRange As Range, DataRange As Range
Dim DestRange As Range
Dim Lr As Long
Dim iCount As Long


With ThisWorkbook
With .Sheets("PROGRAM PERIOD") 'source sheet
Lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Set DataRange = .Range(.Cells(2, 1), .Cells(Lr, 1))
End With


With .Sheets("EXPIRED PROGRAMMING") 'destination sheet
Lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Set DestRange = .Cells(Lr, 1)
End With
End With
DataRange.EntireRow.Hidden = False


For Each c In DataRange.Cells
If IsDate(c.Value) Then
If c.Value < Date Then
If TransferRange Is Nothing Then
Set TransferRange = c
Else
Set TransferRange = Union(TransferRange, c)
End If
iCount = iCount + 1
End If
End If
Next c
If Not TransferRange Is Nothing Then
With TransferRange.EntireRow
.Copy DestRange
.Delete
End With
End If

MsgBox iCount & " Expired Records Transferred", 48, "Expired"
End Sub

 

[rollis13]

Change this line:

Set DataRange = .Range(.Cells(2, 1), .Cells(Lr, 1))

to:

Set DataRange = .Range(.Cells(2, 9), .Cells(Lr, 9)) '<- column I = 9

If the number of cells filled in column A doesn't coincide with the number of cells filled in column I, then you may also need to change previous line to:

Lr = .Cells(.Rows.Count, 9).End(xlUp).Row

 

[nmccracken12]

Change this line:

Set DataRange = .Range(.Cells(2, 1), .Cells(Lr, 1))

to:

Set DataRange = .Range(.Cells(2, 9), .Cells(Lr, 9)) '<- column I = 9

If the number of cells filled in column A doesn't coincide with the number of cells filled in column I, then you may also need to change previous line to:

Lr = .Cells(.Rows.Count, 9).End(xlUp).Row

Good morning and thank you! I changed the first line that you put. It seems to move almost everything over when I run it and it's also not running when the sheet is being opened. I have to manually go and run it. Any ideas? I also noticed that it's moving items over that are not expired and wondering if it's reading dd/mm/yyyy instead of mm/dd/yyyy

I am not stuck with using this code if you know of a better way? I just found this in my searches and figured it was easy for a quick edit than to ask someone to create the entire thing.

 

[dmt32]

Hi,
untested but see if this update to your code will do what you want

Sub TransferExpired()
    Dim TransferRange As Range, DataRange As Range
    Dim DestRange     As Range, c         As Range
    Dim Lr            As Long, iCount     As Long
    
    With ThisWorkbook
        With .Worksheets("PROGRAM PERIOD")        'source sheet
            Lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            Set DataRange = .Cells(2, 9).Resize(Lr)
        End With
        
        With .Worksheets("EXPIRED PROGRAMMING")        'destination sheet
            Lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            Set DestRange = .Cells(Lr, 1)
        End With
    End With
    
    DataRange.EntireRow.Hidden = False
    
    For Each c In DataRange.Cells
        If IsDate(c.Value) Then
            If c.Value < Date Then
                If TransferRange Is Nothing Then
                    Set TransferRange = c
                Else
                    Set TransferRange = Union(TransferRange, c)
                End If
                iCount = iCount + 1
            End If
        End If
    Next c
    
    If Not TransferRange Is Nothing Then
        With TransferRange.EntireRow
            .Copy DestRange
            .Delete
        End With
    End If
    
    MsgBox iCount & " Expired Records Transferred", 48, "Expired"
    
End Sub

Dave

 

[nmccracken12]

Hi,
untested but see if this update to your code will do what you want

Sub TransferExpired()
    Dim TransferRange As Range, DataRange As Range
    Dim DestRange     As Range, c         As Range
    Dim Lr            As Long, iCount     As Long
   
    With ThisWorkbook
        With .Worksheets("PROGRAM PERIOD")        'source sheet
            Lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            Set DataRange = .Cells(2, 9).Resize(Lr)
        End With
       
        With .Worksheets("EXPIRED PROGRAMMING")        'destination sheet
            Lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            Set DestRange = .Cells(Lr, 1)
        End With
    End With
   
    DataRange.EntireRow.Hidden = False
   
    For Each c In DataRange.Cells
        If IsDate(c.Value) Then
            If c.Value < Date Then
                If TransferRange Is Nothing Then
                    Set TransferRange = c
                Else
                    Set TransferRange = Union(TransferRange, c)
                End If
                iCount = iCount + 1
            End If
        End If
    Next c
   
    If Not TransferRange Is Nothing Then
        With TransferRange.EntireRow
            .Copy DestRange
            .Delete
        End With
    End If
   
    MsgBox iCount & " Expired Records Transferred", 48, "Expired"
   
End Sub

Dave

Thank you! This seems to be working except it is not running when I open the file. Any ideas? Do I need to wait a while before opening to check? Previously, I am test, save, close, open, and it does not run. I can manually run it and the information is moving correctly.

 

[dmt32]

Thank you! This seems to be working except it is not running when I open the file. Any ideas?

Glad update resolved your issue.
- to answer your additional question, to do what you want, you would need to call the code from the Workbook Open event

You should have a code like this in the ThisWorkbook code page

Private Sub Workbook_Open()
    TransferExpired
End Sub

Dave

 

[rollis13]

and it's also not running when the sheet is being opened.

This wasn't in your opening post.
If you need to run the macro every time you move through the sheets then you can call the macro Private Sub Worksheet_Activate() instead of Sub TransferExpired() and paste it in the vbe module ("PROGRAM PERIOD").
If it has to run only when you open the workbook you can name it Private Sub Workbook_Open() and paste it in the "ThisWorkBook" module.

 

[nmccracken12]

Glad update resolved your issue.
- to answer your additional question, to do what you want, you would need to call the code from the Workbook Open event

You should have a code like this in the ThisWorkbook code page

Private Sub Workbook_Open()
    TransferExpired
End Sub

Dave

I have pasted that into the ThisWorkbook page and when I run it I get an error that says "Compile Error: Sub or Function not defined" I apologize that this wasn't in the original post. It was in the post that I took that code from and I just overlooked that when I was typing it all out.

 

[dmt32]

If the TransferExpired code in a STANDARD module?

Dave

 

[nmccracken12]

This wasn't in your opening post.
If you need to run the macro every time you move through the sheets then you can call the macro Private Sub Worksheet_Activate() instead of Sub TransferExpired() and paste it in the vbe module ("PROGRAM PERIOD").
If it has to run only when you open the workbook you can name it Private Sub Workbook_Open() and paste it in the "ThisWorkBook" module.

You are correct and I apologize. It was in the thread that I took that code from and I overlooked that when typing.