使代码每两天运行一次/scnan 单元格并添加到 email 主体

Question

我有这个 VBA 代码，我在修改它以每两天运行一次时遇到问题，并且还扫描表以查找低于 100 的任何内容，然后将其添加到 email 正文中。

目前它在每次更改时都会运行并发送 email 但我需要它来扫描表格并查找低于某个数字的项目并将项目名称添加到 email。

如“以下项目是低苹果、橙子、香蕉”

    Dim xRg As Range
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 100 Then Exit Sub
  Set xRg = Intersect(Range("K2:K14"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value < 10 Then
        Call Mail_small_Text_Outlook
    End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim SigString As String
Dim Signature As String

Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)

xMailBody = "ALERT<br><br>" & _
"Inventory levels for " & Range("G2").Value & " labels have hit the threshold for replenishment</b>.<br>"
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Mysig.htm"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If


On Error Resume Next
With xOutMail
.To = "Email"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
'.Body = xMailBody
.HTMLBody = xMailBody & "<br>" & Signature
.Send 'or use .Send
End With

On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function