excel - 变量确定单元格的值,但调用自定义函数并在之后执行
问题描述
代码的目的
我的工作表是协议概述。第一张是概述,每个协议都有自己的一张。这就是为什么我没有遍历第一张纸的原因。凡发现协议结束日期早于今天,则按协议自动延期更新结束日期年份。
问题
我有一个问题,我的工作表需要更新日期字符串,但每当它这样做时,它都会以某种方式调用我的自定义函数,这与它无关。调用自定义函数后,它会执行并更新值。每当它跳入我的功能时:
Function NxtShtNm(number As Long) As String
Application.Volatile True
NxtShtNm = ActiveWorkbook.Sheets(ActiveSheet.Index + number - 1).Name
End Function
它破坏了我单元格中的公式。此公式已用于超链接到概览表中的不同工作表。
价值观
LnLVal 是
10-11-2018 NtceVal 是 8 个月
AutoExtVal 是 5 年
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
目标
我希望我的宏不要使用上述功能跳入我的模块。
我已经尝试过使用:
Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic
但这并没有帮助,它只是延迟跳入模块直到 xlCalculationAutomatic。
提前谢谢你的帮助 :)
解决方案
推荐阅读
- excel - 无法将 Excel 中的 vba 宏与 KEPServer 连接。DDERequest 错误 2023
- java - 无法将项目上传到 AWS Lambda
- yii2 - SQLSTATE [23000]:违反完整性约束:1052 where 子句中的列“名称”不明确.. Yii2
- python - Tensorflow:从张量数组创建数据集
- vue.js - vue konva 可编辑的视频文本
- c# - 尝试调用 Web 服务但出现错误
- mocking - 在 testcafe 中模拟 apollo 查询
- r - lapply 有 2 个向量?一个闪亮的例子
- java - 使用 JavaFX -8 自动调整 TableView 中 TableColumn 的 TableColumn 大小
- azure-devops - 记录错误但管道通过时管道失败