End Dates & Self Destruct Date

Acez_404

New Member
Joined
Feb 24, 2014
Messages
14
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.
 

Some videos you may like

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.

bugmonsta

Board Regular
Joined
Dec 17, 2013
Messages
214
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 :eek:

Code:
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:
Code:
Sub tellmethecolour()
MsgBox ActiveCell.Interior.ColorIndex
End Sub
 
Last edited:

Acez_404

New Member
Joined
Feb 24, 2014
Messages
14
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

New Member
Joined
Feb 24, 2014
Messages
14
Also, the cells are colored by conditional formatting so all the cells are reading "2" (White)
 

bugmonsta

Board Regular
Joined
Dec 17, 2013
Messages
214
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!

Code:
 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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,519
Messages
5,625,273
Members
416,086
Latest member
CaptainGD

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top