在 Windows 上使用新版 Outlook 进行专业沟通和提高工作效率
大神您好,用以下代码都没任何提醒了
StartFragment
Public Sub RunMacroMarkSent()
Dim Target As Range
Application.DisplayAlerts = True
Dim xOutApp As Object
Dim xMailItem As Object
Dim cell As Range
Dim xMailBody As String
Dim KeyColumn As String
Dim CheckValue As String
'On Error Resume Next
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
' Set the target column (column J = column 10)
'If Target.Column = 10 Then
' find the used range
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
' check the date column
For Each cell In Range("J2:J" & lastrow)
'if already sent email, skip
If Range("K" & cell.Row).Value = cell.Value Then GoTo nextrow
If cell.Value = "Expiration" Or cell.Value = "Reminder" Then
'copy value to next cell so you know email sent
Range("K" & cell.Row).Value = cell.Value
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
xMailBody = "Reminder:" & vbNewLine & _
"Worksheet:" & Me.Name & vbNewLine & _
"Location: " & Range("C" & cell.Row).Value & vbNewLine & _
"Content: " & cell.Value & vbNewLine & _
"Time:" & Format(Now, "yyyy-mm-dd hh:mm:ss") & vbNewLine
With xMailItem
.To = "******@xxxx.xxx"
.Subject = "?Excel Reminder?Task due reminder!"
.Body = xMailBody
.Display 'Change to .Send to send automatically
.Save
End With
Set xMailItem = Nothing
Set xOutApp = Nothing
nextrow:
End If
Next cell
'Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
EndFragment