End Dates & Self Destruct Date

[Acez_404]

Good afternoon excel gurus. I'm currently working on a project with several rows that have expiration dates in Column E. I have 2 tabs, 1 labeled "TRACKER" and the other labeled "ARCHIVE". The expiration dates in the tracker tab are set so that once the expiration date is passed, the row turns dark grey then I have to sort these rows by color, copy the grey rows, paste them into the "ARCHIVE" tab and delete the original rows. If possible, can someone please write a macro that will do this automatically? I'm really trying to cut down on small tasks so I can focus on bigger tasks.

Also, is there a macro that can be written that will automatically delete ALL the data in all the tabs (3 total, tracker, archive and ctrl lg) after a certain date? I have a few projects that I want to basically "self destruct" after a certain date so as to protect the confidentiality of my clients and so that I won't accidentally forget to do so. I'm great with formulas but I can't, for the life of me, figure out macros.

 

[bugmonsta]

Hello,

I'll help with the moving of highlighted rows...

In my example I have coloured the lines yellow (colour index 6)

For you to use this, you will need to change the target sheet name and the base name, and change the number highlighted in red below, to see what colour index you are using, pick one of your cells that are highlighted and run the bottom macro.

I will leave the request for purging your sheets to someone else as I like to stay away from purging workbooks

Sub MoveHighlightedRows()

Application.ScreenUpdating = False
Set shTarget = Sheets("A") 'Change as required
Set shBase = Sheets("T") 'Change as required

For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
  If shBase.Cells(i, 1).Interior.ColorIndex =[COLOR="#FF0000"] 6[/COLOR] Then
    shBase.Rows(i).EntireRow.Copy _
    Destination:=shTarget.Rows(shTarget.Cells(shTarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow
    shBase.Rows(i).EntireRow.Delete Shift:=xlUp
  End If
Next i

'Stop any row being highlighted by the copy/paste
Application.CutCopyMode = False
'Tidy up
Set shTarget = Nothing
Set shBase = Nothing
Application.ScreenUpdating = True
End Sub

Finding cell colours:

Sub tellmethecolour()
MsgBox ActiveCell.Interior.ColorIndex
End Sub

 

[Acez_404]

I apologize, maybe I should've been more clear. I have several cells that change to the same grey color, this is why I wanted to go by the expiration dates in Column E. Also, I already have the following code in it:

Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20150716
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("b:b"), Target)
xOffsetColumn = 6
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mmm-yy / hh:mm"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

If possible, I would like to have it still run this but also run the expiration date code as well. I'm sorry if I'm asking for too much. Thank you for your help.

 

[Acez_404]

Also, the cells are colored by conditional formatting so all the cells are reading "2" (White)

 

[bugmonsta]

Hello,

Maybe I read the post wrong!

Anyway - as long as we get to a solution for you...

This will only every run when B is updated as I have added my code into yours. If you need it to check at different times such as when the workbook is open then move the code

I have set this code to look at column E via 'shBase.Cells(i, 5).Value' being greater than column H via 'shBase.Cells(i, 8).Value', you can change this to what ever you need.

Hope this makes sense and gets you on the right path - if not - shout back at me!

 Private Sub Worksheet_Change(ByVal Target As Range)
 'Update 20150716
[COLOR="#FF0000"] Application.ScreenUpdating = False
Set shTarget = Sheets("A") 'Change as required
Set shBase = Sheets("T") 'Change as required[/COLOR]
 
 
 Dim WorkRng As Range
 Dim Rng As Range
 Dim xOffsetColumn As Integer
 Set WorkRng = Intersect(Application.ActiveSheet.Range("b:b"), Target)
 xOffsetColumn = 6
 If Not WorkRng Is Nothing Then
 Application.EnableEvents = False
 For Each Rng In WorkRng
 If Not VBA.IsEmpty(Rng.Value) Then
 Rng.Offset(0, xOffsetColumn).Value = Now
 Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mmm-yy / hh:mm"
 Else
 Rng.Offset(0, xOffsetColumn).ClearContents
 End If
 Next
 
[COLOR="#FF0000"] For i = shBase.Range("E" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
  If shBase.Cells(i, 5).Value > shBase.Cells(i, 8).Value Then
    shBase.Rows(i).EntireRow.Copy _
    Destination:=shTarget.Rows(shTarget.Cells(shTarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow
    shBase.Rows(i).EntireRow.Delete Shift:=xlUp
  End If
  
Next i
 Application.EnableEvents = True
 End If[/COLOR]
 End Sub