我有一个VBA循环,可根据校准日期与当前日期检查何时需要执行校准。它在大多数情况下都可以正常工作,但是会在不需要的地方发送电子邮件。我认为VBA保存先前值的方式有问题。
我尝试打开和关闭excel文档并刷新它。
Sub emailnotice()
'THIS CODE CHECKS THE NEXT CALIBRATION DATE FROM RANGE E3 TO E39 AND CHECKS IT AGAINST THE CURRENT DAY.
'IF THE NEXT DATE IS LESS THAN THE CURRENT DATE THIS CODES SENDS AN EMAIL
Dim cal_date As Range
Dim values As String
Dim todaysdate As Date
Dim element As Range
Dim counter As Integer
Dim value_count As Integer
todaysdate = CDate(Sheets("Calibration").Range("B1")) 'CDate changes the value into Date format
'This allows tests to be added and removed
value_count = Sheets("Calibration").Range("G2").Value + 2
Rng = value_count
Set cal_date = Sheets("Calibration").Range("E3:E" & Rng) 'adjustable range based on count function
counter = 3
For Each element In cal_date
'This block is effectively used to lookup values based on the current loop counter
cellstep = "G" & counter
procedure = "C" & counter
procedure_step = Sheets("Calibration").Range(procedure).Value
Item = "A" & counter
item_step = Sheets("Calibration").Range(Item).Value
If CDate(element) < todaysdate Then
Sheets("Calibration").Range(cellstep).Value = "Fail"
counter = counter + 1
'THIS CODE IS FROM THE TEMPERATURE DATA EXCEL
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = procedure_step & " needs to be performed"
.To = "fakeemail@email.com" ' <-- Put email of the recipient here
' .CC = "..." ' <-- Put email of 'copy to' recipient here
.HTMLbody = "Hi," & "<br><br>" & _
"Perform " & procedure_step & " for the " & item_step & "<br><br>" & _
"<a href=""G:\SOILS\AMRL"">In-House Procedures</a>" & "<br><br> "
'"Regards, " & Application.UserName
'.Attachments.Add PdfFile
' Try to send
On Error Resume Next
.Send
Application.Visible = True
'If Err Then
' MsgBox "E-mail was not sent", vbExclamation
'Else
' MsgBox "E-mail successfully sent", vbInformation
'End If
'On Error GoTo
End With
' Delete PDF file
'Kill PdfFile
' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
Else
Sheets("Calibration").Range(cellstep).Value = "Pass"
counter = counter + 1
End If
Next
Sheets("Calibration").Range("F2:F38").Value = values
End Sub
我希望此代码不发送不必要的校准电子邮件。