How do I add a fixed value to a cell every month which is then automatically updated?
How do I add a fixed value to a cell every month which is then automatically updated?
I have no idea how you do that.
I would set up another sheet in the work book with a column headed months and put the fixed value in that column The first column would be the start value
I would have a formula where I wanted the result to sum the start value and all of the months values.
Alternatively (and more likely) I would have a sheet where I would save the las run date.
A button to run a macro which would ask for the fixed value. It would check to see if it had been run this month add the values and srore the run date. the date checking is to stop it running twice for the same month. As I got more lazy I would add this to workbook code sheet so that it ran when the workbook opened automaticaly.
Please paste the code below in the code module ThisWorkbook of a workbook which you set up for testing. Make sure the workbook has a worksheet called Sheet1 or change the sheet name at the top of the code. Save the workbook as macro-enabled.
Option Explicit
Private Sub Workbook_Open()
' 06 Sep 2019
Const Target As String = "Sheet1!A3" ' cell to increment: change as required
Const Pname As String = "Last Increment"
Dim Prop As DocumentProperty
Dim Pdate As Variant
Dim Ws As Worksheet ' worksheet specified in 'Target'
Dim Rng As Range ' cell specified in 'Target'
Dim Sp() As String
Dim Mdiff As Long
Dim OK As Boolean
With CustomDocumentProperties
On Error Resume Next
Set Prop = .Item(Pname)
If Err Then
' create the Property, if it didn't exist, with current date
Set Prop = .Add(Pname, False, msoPropertyTypeDate, Date)
End If
End With
Pdate = Prop.Value
If Not IsDate(Pdate) Then
' If property isn't a date, assign current date
Prop.Type = msoPropertyTypeDate
Pdate = Date
End If
Sp = Split(Target, "!")
OK = (UBound(Sp) = 1)
If OK Then
Set Ws = ThisWorkbook.Worksheets(Sp(0))
Set Rng = Ws.Range(Sp(1))
OK = (Err.Number = 0)
End If
If OK Then
' calculate the number of months lapsed since Last Increment
' the Dateserial formula calculates the date of the last day of the month in Pdate
Mdiff = DateDiff("m", DateSerial(Year(Pdate), Month(Pdate) + 1, 0), Date)
If Mdiff Then
Rng.Value = Rng.Value + Increment(Mdiff)
Prop.Value = Date
End If
Else
MsgBox "The constant ""Target"" must specify an existing" & vbCr & _
"worksheet, its name separated from the cell address" & vbCr & _
"by an exclamation point.", vbCritical, "Coding Error"
End If
End Sub
Private Function Increment(ByVal Mdiff As Long) As Double
' 06 Sep 2019
Increment = 0.25 * Mdiff
End Function
The code will run automatically whenever the workbook is opened. But you can also run it manually by placing the cursor anywhere in the sub Workbook_Open and pressing F5. The comments I have added may help you understand what the code does but so will the explanation below.
The code looks for a custom document property (File > Properties > Advanced Properties > Custom) by the name of Last Increment (change the name in the code). If it doesn't exist, it will be added.
If the last increment was in a previous month (not: if one month has passed since) the Target cell will be incremented, meaning, a calculated value will be added to the existing one. At the same time the Last Increment property will be assigned the date of the action. (The property value can also be modified in the properties dialog.)
I placed the calculation of the increment in a separate function. That isn't strictly necessary but it provides the infrastructure to make the calculation quite complicated, if that is required. I proceded from the idea of an increasing rate of interest to be charged, or perhaps a monthly fee. This would require that several months' worth of increment should be added, if the update was missed previously. Toward this end the function receives the months-difference (Mdiff) as an argument.