VBA automatic due date adjustment with conditions

[Mulvey]

Hello any help given is much appreciated I am quite new to Macros and VBA
I am trying to modify a scheduling spreadsheet for Time Based Maintenance, the sheet has a list of TBMs and the frequency they need to be done (Weekly, monthly, yearly etc) and the next due date they need to be planned for and the status 1= completed 0 or blank=not completed.
I need to be able to type a date in the due date cell so it is static but i want it to automatically change the date when the status cell is changed to 1 by either 1 month, 6 months, 1 year depending on what is set in the frequency column for that row if it is set to monthly and i put the status to 1 it will adjust the date by 1 month same for yearly and 6 monthly,


[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Action[/TD]
[TD] Frequency [/TD]
[TD] status[/TD]
[TD] Due Date[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Conveyor 1 Service[/TD]
[TD]Annual[/TD]
[TD]0[/TD]
[TD]1 Sep 17
[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Conveyor 2 Service[/TD]
[TD]Monthly[/TD]
[TD]0[/TD]
[TD]1 Sep17[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Conveyor 3 Service[/TD]
[TD]Monthly[/TD]
[TD]1[/TD]
[TD]1 Oct 17[/TD]
[/TR]
</tbody>[/TABLE]

Once the status is changed to 1 and the date is reset the status then needs to revert back to blank or 0.

Cheers

 

[Peter h]

I'm working on some code to help you out. I feel like I've got most of it worked out, but I'm finding it difficult to figure out how to have the macro run when you input the value into the "Status" cell. I'll keep working on it and when I get something figured out I'll give you the code.

 

[Peter h]

Ok, I came up with some code that accomplishes what you're wanting to do, I think. In your workbook, right-click on the sheet that you have your scheduling on and select "View Code". Paste this code there.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.OnKey "{97}", "Change_Date"
    Application.OnKey "1", "Change_Date"
End Sub

Then in a new Module (At the top click Insert>Module), paste this code.

Sub Change_Date()
Dim ADate As Date
Dim MDate As Date
Dim WDate As Date
With ThisWorkbook
    If Not ActiveCell.Column = 3 Then
        ActiveCell = "1"
        Exit Sub
    Else
        If .Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Cells(ActiveCell.Row, ActiveCell.Column - 1) = "Annual" Then
            ADate = DateAdd("YYYY", 1, Cells(ActiveCell.Row, ActiveCell.Column + 1))
            MsgBox "By changing the value of this cell to 1, the current due date will be updated, and the Status will be reset to 0."
            .Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Cells(ActiveCell.Row, ActiveCell.Column + 1) = ADate
            ActiveCell.Value = "0"
        ElseIf .Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Cells(ActiveCell.Row, ActiveCell.Column - 1) = "Monthly" Then
            MDate = DateAdd("M", 1, Cells(ActiveCell.Row, ActiveCell.Column + 1))
            MsgBox "By changing the value of this cell to 1, the current due date will be updated, and the Status will be reset to 0."
            .Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Cells(ActiveCell.Row, ActiveCell.Column + 1) = MDate
            ActiveCell.Value = "0"
        ElseIf .Sheets("[COLOR=#ff0000]Sheet1")[/COLOR].Cells(ActiveCell.Row, ActiveCell.Column - 1) = "Weekly" Then
            WDate = DateAdd("WW", 1, Cells(ActiveCell.Row, ActiveCell.Column + 1))
            MsgBox "By changing the value of this cell to 1, the current due date will be updated, and the Status will be reset to 0."
            .Sheets("[COLOR=#ff0000]Sheet1")[/COLOR].Cells(ActiveCell.Row, ActiveCell.Column + 1) = WDate
            ActiveCell.Value = "0"
        End If
    End If
End With
End Sub

This code assumes that the "Status" column is in Column "C" like your example at the top. Also, Make sure the reference to the sheet is correct for your application (Change the red text in my code to whatever the name of your sheet is).

Let me know if this is working properly, or if you need any other help.

Edit: It should be noted that I was also assuming that cells in Column "B" will only contain either "Annual", "Monthly", or "Weekly". If the cell contains anything other than those, the macro won't update the date in column "D".

 

[My Aswer Is This]

Try this:

This script only works if "Annual" or "Monthly" is entered into column "B"

If you put a 3 in column "C" the date in column "D" advances by 3 months if you have "Monthly" in column "B"
If you put any number greater then "0" in column "C" the date in column "D" advances by 1 year. If you have "Annual" in column "B"

This is an auto sheet event script
Your Workbook must be Macro enabled
To install this code:
Right-click on the sheet tab
Select View Code from the pop-up context menu
Paste the code in the VBA edit window

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "C").End(xlUp).Row
If Not Intersect(Target, Range("C2:C" & Lastrow)) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value > 0 Then
If Target.Offset(0, -1).Value = "Annual" Then Target.Offset(0, 1).Value = DateAdd("M", 12, Target.Offset(0, 1).Value): Target.Value = ""
If Target.Offset(0, -1).Value = "Monthly" Then Target.Offset(0, 1).Value = DateAdd("M", Target.Value, Target.Offset(0, 1).Value): Target.Value = ""
End If
End If
End Sub

 

[Mulvey]

Thank you Peter that works brilliantly I put the sheet name in as you said and I had to adjust the column numbers as there is a few others in there but that was no problem. Is it possible for it to do quarterly (3 Month) 6 Monthly and 6 Weekly also I know it will be mostly replicating the other codes and changing a minor part im just not sure what to put in to make it do those time frames.
Your help in this matter has bee greatly appreciated

 

[Mulvey]

Thank you for your suggestion your time and effort is appreciated

 

[Peter h]

Thank you Peter that works brilliantly I put the sheet name in as you said and I had to adjust the column numbers as there is a few others in there but that was no problem. Is it possible for it to do quarterly (3 Month) 6 Monthly and 6 Weekly also I know it will be mostly replicating the other codes and changing a minor part im just not sure what to put in to make it do those time frames.
Your help in this matter has bee greatly appreciated

Here is a link that explains the "DateAdd" function:
https://msdn.microsoft.com/en-us/library/hcxe65wz(v=vs.90).aspx

As you will see in that link there are many different ways to add time to a given date. But to simplify it for you, all you have to do is change the interval in the syntax. So for example, in my code the syntax is:

ADate = DateAdd("YYYY", 1, Cells(ActiveCell.Row, ActiveCell.Column + 1))

ADate is the date you want to change Annually. So in the DateAdd line, the "YYYY" is telling Excel that you are wanting to add to the Year in the date you are looking at. The "1" is telling Excel how many years you want to add to the year. This can be any number, and when the macro is run it will add that number to the year. And then the "Cells(ActiveCell.Row, ActiveCell.Column +1))" is the reference to the date you want changed.

So lets say you wanted to add a quarterly due date to your table, what you would be modifying is the number of months added to your date. I would create a new variable (something like QDate). You'd have to create another "ElseIf" block to include a check for the additional "Quarterly" in your Frequency column. And the DateAdd line would look like:

QDate = DateAdd("M", 3, Cells(ActiveCell.Row, ActiveCell.Column + 1))

The Same would be true if you wanted to do every 6 months, just change the 3 to 6. Also the same is true for the 6 Weekly. You would just change the number in the syntax after the "WW".

I hope this helps.

I haven't tried My Aswer Is This's code. It may be a more efficient way to accomplish the same thing. You might want to try both to see which one you like best. He's given me lots of help with my coding issues in the past.

Keep us posted.

 

[Mulvey]

Great that worked perfectly thank you both for your help and time you have saved me a massive amount of time as there are around 3000 rows of these TBMs on this sheet and more are being added. all the best to you both.

 

[My Aswer Is This]

In your original post image you only showed "Monthly" and "Annual" That is why I wrote my script the way I did.

I changed my script to work with four choices you can put into column "B"
"Daily"
"Weekly"
"Monthly"
"Yearly"

If you put "1" in column "C" the date in column "D" will advance by either 1 day 1 week 1 Month or 1 Year

Depending on what choice you made in column "C"
If you put "2" in column "C" the date in column "D" will advance by either 2 days 2 weeks 2 Months or 2 Years Depending on what choice you made in column "C"

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lastrow As Long
'Modified 7-7-17 11:28 AM EDT
Lastrow = Cells(Rows.Count, "C").End(xlUp).Row
If Not Intersect(Target, Range("C2:C" & Lastrow)) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If IsNumeric(Target.Value) = True And Target.Value > 0 Then
If Target.Offset(0, -1).Value = "Daily" Then Target.Offset(0, 1).Value = DateAdd("D", Target.Value, Target.Offset(0, 1).Value): Target.Value = ""
If Target.Offset(0, -1).Value = "Weekly" Then Target.Offset(0, 1).Value = DateAdd("WW", Target.Value, Target.Offset(0, 1).Value): Target.Value = ""
If Target.Offset(0, -1).Value = "Monthly" Then Target.Offset(0, 1).Value = DateAdd("M", Target.Value, Target.Offset(0, 1).Value): Target.Value = ""
If Target.Offset(0, -1).Value = "Yearly" Then Target.Offset(0, 1).Value = DateAdd("YYYY", Target.Value, Target.Offset(0, 1).Value): Target.Value = ""
End If
End If
End Sub