Macro to archive and delete data question

[2001sleeper]

Hello,
As many other posts I am a beginner and not sure where to start.
I have a spreadsheet for process pH values that is setup as follows:

[TABLE="width: 415"]
<colgroup><col><col span="4"></colgroup><tbody>[TR]
[TD]Date[/TD]
[TD="align: right"]8/1/2017[/TD]
[TD="align: right"]8/2/2017[/TD]
[TD="align: right"]8/3/2017[/TD]
[TD="align: right"]8/4/2017[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]PH[/TD]
[TD]PH[/TD]
[TD]PH[/TD]
[TD]PH[/TD]
[TD]PH[/TD]
[/TR]
[TR]
[TD]Sump1[/TD]
[TD]7.85[/TD]
[TD]7.52[/TD]
[TD]7.46[/TD]
[TD]7.38[/TD]
[/TR]
[TR]
[TD]Sump2[/TD]
[TD]7.54[/TD]
[TD]7.48[/TD]
[TD]7.20[/TD]
[TD]7.40[/TD]
[/TR]
[TR]
[TD]Sump3[/TD]
[TD]8.03[/TD]
[TD]8.42[/TD]
[TD]7.53[/TD]
[TD]7.50[/TD]
[/TR]
</tbody>[/TABLE]

Row 1 is where the dates are found and I am wanting to have a macro that will only keep TODAY()-7 days. So basically, every day I open the spreadsheet OR manually run the macro, all columns older than 7 days will be cut and relocated to an Archive spreadsheet and the empty columns will be deleted allowing the data to shift left.

Is this possible?

 

[MrTeeny]

Yes, with excel you can run macro's when the worksheet opens, closes or saves. You'd just set a Workbooks.Open routine to run your code and dump the columns to your archive worksheet. Is the Archive part of your current workbook or a separate workbook, either way both are possible it's just obviously easier to dump the data in a separate worksheet within the workbook than opening another workbook to write to

 

[2001sleeper]

I am wanting to move the data in the same workbook.

 

[MrTeeny]

You could try something like this code to get you started, just copy and save it under the thisWorkbook object in the vba editor, it should run the code when you open the file, other options are to run it before closing or before saving automatically. It's assuming the sheets are called Data and Archive as I've no idea what you've called them, the archive data is inserted in column A to try and keep it consecutive

Private Sub Workbook_Open()
Dim LastCellData As Integer, LastColumnData As Integer, LastColumnArchive As Integer, i As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculateManual
On Error GoTo xit:

LastColumnData = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column

For i = LastColumnData To 2 Step -1

If DateDiff("d", Sheets("Data").Cells(1, i).Value, Now()) > 7 Then
LastColumnArchive = Sheets("Archive").Cells(1, Columns.Count).End(xlToLeft).Column
LastCellData = Sheets("Data").Cells(Rows.Count, i).End(xlUp).Row
Sheets("Archive").Range("A1").EntireColumn.Insert


Sheets("Archive").Range(Sheets("Archive").Cells(1, 1), Sheets("Archive").Cells(LastCellData, 1)).Value = _
Sheets("Data").Range(Sheets("Data").Cells(1, i), Sheets("Data").Cells(LastCellData, i)).Value


Sheets("Data").Columns(i).EntireColumn.Delete

End If
Next i

xit:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[2001sleeper]

Great!
I will give it try tomorrow and play around with it.

Instead of inserting the data on the archive worksheet, is just adding to the columns to the end possible?

 

[MrTeeny]

If you want them at the end try this, it should hopefully retain the order too

Private Sub Workbook_Open()
Dim LastCellData As Integer, LastColumnData As Integer, LastColumnArchive As Integer, i As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculateManual
On Error GoTo xit:


LastColumnData = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column


For i = LastColumnData To 2 Step -1


If DateDiff("d", Sheets("Data").Cells(1, i).Value, Now()) > 7 Then
LastColumnArchive = Sheets("Archive").Cells(1, Columns.Count).End(xlToLeft).Column
LastCellData = Sheets("Data").Cells(Rows.Count, i).End(xlUp).Row






Sheets("Archive").Range(Sheets("Archive").Cells(1, LastColumnArchive + 1), Sheets("Archive").Cells(LastCellData, LastColumnArchive + 1)).Value = _
Sheets("Data").Range(Sheets("Data").Cells(1, i), Sheets("Data").Cells(LastCellData, i)).Value




Sheets("Data").Columns(i).EntireColumn.Delete




End If
Next i


xit:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub