Odtnhj

The purpose of the code

My sheet is an overview of agreements. The first sheet is the overview, and the every agreement has a sheet for itself. Which is why i does not loop through the first sheet. Whenever it finds the end date of the agreement is prior to the date of today, then it shall renew the end date year according to the agreement automatic extension.

Problem

I have a problem, where my sheet is required to update a date string, but whenever it does so, it somehow calls my custom function, that has nothing to do with it. After having called the custom function, it executes and it has updated the value. Whenever it jumps into my function which is:

 Function NxtShtNm(number As Long) As String
 Application.Volatile True
 NxtShtNm = ActiveWorkbook.Sheets(ActiveSheet.Index + number - 1).Name
 End Function

it destroys the formula in my cell. This formula has been used to hyperlink to the different sheets from the overview sheet.

Values

LnLVal is 10-11-2018

NtceVal is 8 months

AutoExtVal is 5 years

Sub Message()
Dim sht As Worksheet
Dim c As Range
Dim Wf As WorksheetFunction
Dim LastRow As Long
Dim OblLeftLR As String, NtceLR As String
Set sht = Sheets(1)
Set Wf = WorksheetFunction
Dim vR() As Variant
Dim k As Long, j As Integer

OblLeft = sht.Range("1:1").Find("Obligation left").Address(False, False, xlA1)
OblLeftSub = sht.Range(OblLeft).Application.WorksheetFunction.Substitute(OblLeft, "1", "")
OblLeftOff = sht.Range(OblLeft).Offset(1, 0).Address(False, False, xlA1)
OblLR = sht.Cells(sht.Rows.Count, OblLeftSub).End(xlUp).Row
rngOblLeft = OblLeftOff & ":" & OblLeftSub & OblLR
rngOblMinus = WorksheetFunction.CountIf(Range(rngOblLeft), "")
rngObl = OblLeftOff & ":" & OblLeftSub & OblLR - rngOblMinus

Ntce = sht.Range("1:1").Find("Notice").Address(False, False, xlA1)
NtceSub = sht.Range(Ntce).Application.WorksheetFunction.Substitute(Ntce, "1", "")
NtceOff = sht.Range(Ntce).Offset(1, 0).Address(False, False, xlA1)
NtceLR = sht.Cells(sht.Rows.Count, NtceSub).End(xlUp).Row
rngNtce2 = NtceOff & ":" & NtceSub & NtceLR
rngNtceMinus = WorksheetFunction.CountIf(Range(rngNtce2), "")
rngNtce = NtceOff & ":" & NtceSub & NtceLR - rngNtceMinus

StreNme = sht.Range("1:1").Find("Store").Address(False, False, xlA1)
StreNmeSub = sht.Range(StreNme).Application.WorksheetFunction.Substitute(StreNme, "1", "")
StreNmeOff = sht.Range(StreNme).Offset(1, 0).Address(False, False, xlA1)
StreNmeVal2 = ""

AutoExt = sht.Range("1:1").Find("Automatical extension of contract").Address(False, False, xlA1)
AutoExtSub = sht.Range(AutoExt).Application.WorksheetFunction.Substitute(AutoExt, "1", "")

LnL = sht.Range("1:1").Find("Lease end lessee").Address(False, False, xlA1)
LnLSub = sht.Range(LnL).Application.WorksheetFunction.Substitute(LnL, "1", "")

MyDate = Date

On Error Resume Next

For Each c In Range(rngObl).Cells
 If Not IsEmpty(c) Then
 CValue = c.Value
 CAddress = c.Address(False, False, xlA1)
 NtceAddress = sht.Range(CAddress).Application.WorksheetFunction.Substitute(CAddress, OblLeftSub, NtceSub)
 NtceValue = sht.Range(NtceAddress).Value
 NtceVal = Left(NtceValue, WorksheetFunction.Find(" ", NtceValue) - 1)
 CVal = Left(CValue, WorksheetFunction.Find(" ", CValue) - 1)
 Rslt = CVal - NtceVal
 If Rslt <= 3 Then
 StreNmeAddress = sht.Range(CAddress).Application.WorksheetFunction.Substitute(CAddress, OblLeftSub, StreNmeSub)
 StreNmeVal = sht.Range(StreNmeAddress).Value
 AutoExtAddress = sht.Range(CAddress).Application.WorksheetFunction.Substitute(CAddress, OblLeftSub, AutoExtSub)
 AutoExtVal = sht.Range(AutoExtAddress).Value
 RsltMsg = Rslt & " month(s) - "
 If Rslt = 0 Then
 LnLAddress = sht.Range(CAddress).Application.WorksheetFunction.Substitute(CAddress, OblLeftSub, LnLSub)
 LnLVal = sht.Range(LnLAddress).Value
 Rslt = DateDiff("d", MyDate, LnLVal) - 365
 RsltMsg = Rslt & " days - "
 If Rslt = 1 Then
 RsltMsg = Rslt & " day - "
 End If
 End If
 If Rslt = 1 Then
 RsltMsg = Rslt & " month - "
 End If
 Msg = StreNmeVal2 & vbNewLine & StreNmeVal & " will renew in " & RsltMsg & AutoExtVal
 End If
 StreNmeVal2 = Msg
 End If
Next

On Error GoTo 0

MsgBox "The rent agreements for the following stores will automatically renew its period, within the next 3 months:" & vbNewLine & Msg

End Sub

Sub UpdateSheets()
Dim WS_count As Integer
Dim I As Integer
Dim sht As Worksheet

Today = Date

WS_count = ActiveWorkbook.Worksheets.Count

For I = 1 To WS_count
 If I = 1 Then
 Else
 Set sht = Sheets(I)
 LnLAddress = sht.Range("A:A").Find("Lease end lessee:", , LookIn:=xlValues).Address(False, False, xlA1)
 LnLOff = sht.Range(LnLAddress).Offset(0, 1).Address(False, False, xlA1)
 LnLVal = sht.Range(LnLOff).Value
 NtceAddress = sht.Range("A:A").Find("Notice:", , LookIn:=xlValues).Address(False, False, xlA1)
 NtceOff = sht.Range(NtceAddress).Offset(0, 1).Address(False, False, xlA1)
 NtceVal = sht.Range(NtceOff).Value
 On Error GoTo Ending:
 NtceVal = Left(NtceVal, Application.WorksheetFunction.Find(" ", NtceVal) - 1)
 LnLVal = DateSerial(Year(LnLVal), Month(LnLVal) - NtceVal, Day(LnLVal))
 LnLYear = Year(LnLVal)
 On Error GoTo 0
 If LnLYear <= Year(Today) Then
 LnLMonth = Month(LnLVal)
 If LnLMonth <= Month(Today) Then
 LnLDay = Day(LnLVal)
 If LnL < Day(Today) Then
 AutoExtAddress = sht.Range("A:A").Find("Automatical extension of contract", , LookIn:=xlValues).Address(False, False, xlA1)
 AutoExtOff = sht.Range(AutoExtAddress).Offset(0, 1).Address(False, False, xlA1)
 AutoExtVal = sht.Range(AutoExtOff).Value
 AutoExt = Left(AutoExtVal, Application.WorksheetFunction.Find(" ", AutoExtVal) - 1)
 LnLNewVal = DateSerial(Year(LnLVal) + AutoExt, Month(LnLVal) + NtceVal, Day(LnLVal))
 Application.Calculation = xlCalculationManual
 sht.Range(LnLOff).Value = LnLNewVal
 Application.Calculation = xlCalculationAutomatic
 End If
 End If
 End If
 End If
Ending:
On Error GoTo 0
Next I

End Sub

Goal

I want my macro not to jump into my Module with the abovementioned function.

I have already tried to use:

Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic

But this hasn't helped, it just delayed jumping into the module until xlCalculationAutomatic.

Thank you for your help in advance :)