Need VBA that deletes content of cell based on adjacent cell's date being older than 21 days

[MJ72]

Let's say I have 3 columns; "Date", "Contact#", "Notes". Because of privacy restrictions, the information in the cells of the "Contact #" column need to be deleted once their corresponding entry date in the "Date" column reaches 20 days past it's date. I do not, however, need the "Date" column, nor the "Notes" column to be deleted as well. Date = ("G6:G40") and Contact = ("H6:H40"). I know I need an IF statement and Range but can't seem to get it to delete just the cells in "H" that correspond with dates in "G" that are older than 20 days. I'm newish to Excel VBA and have run myself ragged trying to find the solution or combo of solutions online, so... here I am.

I humbly beg for your help

Date	Contact	Notes
2021-08-02​	X	set for delete
2021-08-01​	X
2021-07-31​	X
2021-07-30​	X

.

 

[JGordon11]

Try this on a test copy of your worksheet. Note that if your DateRange is going to change in size or location this is not going to work.

Sub DeleteOld()
    Dim DateRange As Range, d
    Const AgeCriterion = 21
    Set DateRange = ActiveSheet.Range("G6:G40")
    For Each d In DateRange
        If Now() - d.Value > AgeCriterion Then
            d.Offset(0, 1).ClearContents
        End If
    Next
End Sub

 

[MJ72]

Try this on a test copy of your worksheet. Note that if your DateRange is going to change in size or location this is not going to work.

Sub DeleteOld()
    Dim DateRange As Range, d
    Const AgeCriterion = 21
    Set DateRange = ActiveSheet.Range("G6:G40")
    For Each d In DateRange
        If Now() - d.Value > AgeCriterion Then
            d.Offset(0, 1).ClearContents
        End If
    Next
End Sub

Thank you JG, it's almost perfect! No, the date range won't be changing as it will always be 21 days from the date entered and the chance of having more than 34 entries is slim to none. The next query is how to have the macro run every time the excel file is opened?

 

[JGordon11]

Put this in the ThisWorkbook Module (access by double clicking ThisWorkbook in the list of Microsoft Excel Objects in the VBA projects panel):

Private Sub Workbook_Open()
    Sheets("Sheet1").Activate
    DeleteOld
End Sub

Change "Sheet1" to the correct name of your sheet.

 

[MJ72]

Put this in the ThisWorkbook Module (access by double clicking ThisWorkbook in the list of Microsoft Excel Objects in the VBA projects panel):

Private Sub Workbook_Open()
    Sheets("Sheet1").Activate
    DeleteOld
End Sub

Change "Sheet1" to the correct name of your sheet.

Awesome, JG! Thank you very much!