Delete Column Based on Date

[rchansen2001]

I am trying create a VBA macro to delete columns based on the date but I am a beginner with VBA. I have a report which I only want to use data from the last 10 days. The dates are in row 1 as the heading and is updated each day with a new column at the end for the current date. Columns A:J (contain required data) then columns K through the last column contain dates. I run the report each day and only want to keep the last 10 days data. Example the report has Column K (12/21/2015) through Column ID (11/30/2016) and I only want to keep (11/11/2016 - 11/30/2016) the last 10 working days.

 

[seguin85]

Try:

Private Sub Worksheet_Activate()

Application.ScreenUpdating = False


Dim TDate As Date


Do Until Range("K1").Value > TDate - 10


    Range("K1").Columns.Delete
    
Loop


Application.ScreenUpdating = True


End Sub

 

[rchansen2001]

seguin85, Thanks for the reply but this didn't do anything. I do have two columns Titled "RSN" and "Note" which I delete manually as well after running the macro. Not sure if this has any effect on the code you wrote. As I said I am a beginner with VBA.

Try:

Private Sub Worksheet_Activate()

Application.ScreenUpdating = False


Dim TDate As Date


Do Until Range("K1").Value > TDate - 10


    Range("K1").Columns.Delete
    
Loop


Application.ScreenUpdating = True


End Sub

 

[seguin85]

This must be placed in the worksheet module and will activate as soon as you activate the sheet. This code assumes your dates start in K1 and continue to the right. If your dates start in a different cell replace K1 with that cell address. Try this code, you can assign it to a button or press F5 to run it (while you are in the code window):

Sub newCode()

Application.ScreenUpdating = False


Dim TDate As Date


Do Until Range("K1").Value > TDate - 10


    Range("K1").Columns.Delete
    
Loop


Application.ScreenUpdating = True


End Sub

 

[rchansen2001]

My original macro included below still works but it doesn't delete any of the date columns. It seems to just skip over your code.
An alternate way of writing the code would be to delete columns K:lastcolumn except for the last 12 columns. I am unsure how to do this because each day 1 more column is automatically added for the current date.
Code:
Sub RDU_2()
Application.ScreenUpdating = False
Dim TDate As Date

Range("A1").Select
ActiveCell.FormulaR1C1 = "JO/KO"
Range("B1").Select
ActiveCell.FormulaR1C1 = "TITLE"

Range("E:E,G:J,L:L,N:O,Q:T,W:AA").Select
Selection.EntireColumn.Delete


Do Until Range("K1").Value > TDate - 10
Range("K1").Columns.Delete

Loop

Columns("A:A").Select
Selection.ColumnWidth = 15
Columns("B:B").Select
Selection.ColumnWidth = 48
Columns("B:B").EntireColumn.AutoFit
Columns("C:D").Select
Selection.ColumnWidth = 19.29
Columns("E:F").Select
Selection.ColumnWidth = 9.29
Columns("G:G").Select
Selection.ColumnWidth = 3.57
Columns("H:J").Select
Selection.ColumnWidth = 5
Columns("K:T").Select
Selection.ColumnWidth = 2.86

Application.ScreenUpdating = True

End Sub

This must be placed in the worksheet module and will activate as soon as you activate the sheet. This code assumes your dates start in K1 and continue to the right. If your dates start in a different cell replace K1 with that cell address. Try this code, you can assign it to a button or press F5 to run it (while you are in the code window):

Sub newCode()

Application.ScreenUpdating = False


Dim TDate As Date


Do Until Range("K1").Value > TDate - 10


    Range("K1").Columns.Delete
    
Loop


Application.ScreenUpdating = True


End Sub

 

[seguin85]

Hope this does the trick:

If Range(Cells(1, 11), Cells(1, 11).End(xlToRight)).Count > 12 Then    
     Columns.Range(Cells(1, 11), Cells(1, 11).End(xlToRight).Offset(0, -12)).Delete
End If

It counts the number of cells from K to the last populated cell, if it is 12 or under it leaves it alone. If the number is above 12 it deletes all the columns except the last 12.

 

[rchansen2001]

seguin85, Thank you for your help it worked to delete the top row of each column I wanted so I just added EntireColumn before delete and it works perfect.

If Range(Cells(1, 11), Cells(1, 11).End(xlToRight)).Count > 12 Then
     Columns.Range(Cells(1, 11), Cells(1, 11).End(xlToRight).Offset(0, -12)).EntireColumn.Delet 
End If

Hope this does the trick:

If Range(Cells(1, 11), Cells(1, 11).End(xlToRight)).Count > 12 Then    
     Columns.Range(Cells(1, 11), Cells(1, 11).End(xlToRight).Offset(0, -12)).Delete
End If

It counts the number of cells from K to the last populated cell, if it is 12 or under it leaves it alone. If the number is above 12 it deletes all the columns except the last 12.