如何实现邮箱或微信提醒

匿名

大神们您好，恳请大神们帮助.......

H ,I, J ,K列中的值通过都是函数公式自动更新值，用下面的代码......必须双击J列的单元格值才会触发QQ邮箱消息通知......想J列的函数公式自动更新值时就会自动触发QQ邮箱消息通知......如何解决这个难题.......请教各位大神们......期待帮助......祝开心快乐每一天.....谢谢！

Private Sub Worksheet_Change(ByVal Target As Range)

    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 

    ' 设置目标列（J列 = 第10列） 

    If Target.Column = 10 Then 

        For Each cell In Target 

            If LCase(cell.Value) = "到期" Or LCase(cell.Value) = "提醒" Then 

                Set xOutApp = CreateObject("Outlook.Application") 

                Set xMailItem = xOutApp.CreateItem(0) 

                xMailBody = "提醒：" & vbNewLine & _ 

                            "工作表：" & Me.Name & vbNewLine & _ 

                            "位置：" & cell.Address(False, False) & vbNewLine & _ 

                            "内容：" & cell.Value & vbNewLine & _ 

                            "时间：" & Format(Now, "yyyy-mm-dd hh:mm:ss") & vbNewLine & _ 

                            "用户：" & Environ$("username") 

                With xMailItem 

                    .To = "收件人邮箱@example.com" 

                    .Subject = "【Excel提醒】任务到期提醒！" 

                    .Body = xMailBody 

                    .Display  '改为.Send 可自动发送 

                End With 

                Set xMailItem = Nothing 

                Set xOutApp = Nothing 

            End If 

        Next cell 

    End If 

    Application.DisplayAlerts = True 

    Application.ScreenUpdating = True 

End Sub

锁定的问题。此问题已从 Microsoft 支持社区迁移。你可投票决定它是否有用，但不能添加评论或回复，也不能关注问题。

0 个注释

问题作者接受的答案

匿名

TestMacro.xlsm (更新版) 没有弹窗警示，而你的可能用到了外链数据。不影响，let it be。度盘分享的TestMacro.xlsm，明天下午将删除。

Btw，为了这么个软件需求，多次持续发帖、跟进这么久，真是很拼！单位但凡有一点点预算的话，找个专业软开公司，就不用如此劳神。

0 个注释

问题作者接受的答案

匿名

.txt里检索：五星，仍不清楚就罢了。TestMacro.xlsm 更新了。与宏代码无关，应该是你.xlsm文件的问题；对使用没有影响，不用处理。

0 个注释

问题作者接受的答案

匿名

大神您好，问题已解决，谢谢您的耐心指导......

文档每次保存时都弹出下图这样提示：请注意！文档的部分内容肯包含文档检查器无法删除的个人信息......

这个对使用有没影响.....要不要处理.....谢谢指导！

下载到TestMacro.xlsm文件了？这个小问题明天抽空研究一下。对了，Office readme.txt文末，那款free app on play store你有条件帮忙，五星打分支持一下么？谢谢先！

0 个注释

问题作者接受的答案

匿名

J列的函数公式是什么？看看J列有没有On Change事件？有的话，在此事件中，执行判断与发邮件的逻辑代码。

此外，看你截图是手机上，注意手机版Office里宏代码没法执行。

0 个注释

28 个其他答案

匿名

![](https://learn-attachment.microsoft.com/api/attachments/d077d713-1858-421f-83aa-29c653fae268?platform=QnAJ列的函数公式是:

=IF(I3="","",IF(OR(K3={"无需处理","处理完毕","取消","续费","销户","变更","升档","降档"}),"",

IF(I3<...., .....）））

我用手机版Office 的来截的图，操作是用电脑版Win10系统，电脑的微软365家庭版，Office的

我的Excel 工作表怎么发您呢？

以下的代码是位大神发我的.......这个难题怎么解决......恳请帮助......谢谢

Private Sub Worksheet_Change(ByVal Target As Range)

    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 

    ' 设置目标列（J列 = 第10列） 

    If Target.Column = 10 Then 

        For Each cell In Target 

            If LCase(cell.Value) = "到期" Or LCase(cell.Value) = "提醒" Then 

                Set xOutApp = CreateObject("Outlook.Application") 

                Set xMailItem = xOutApp.CreateItem(0) 

                xMailBody = "提醒：" & vbNewLine & _ 

                            "工作表：" & Me.Name & vbNewLine & _ 

                            "位置：" & cell.Address(False, False) & vbNewLine & _ 

                            "内容：" & cell.Value & vbNewLine & _ 

                            "时间：" & Format(Now, "yyyy-mm-dd hh:mm:ss") & vbNewLine & _ 

                            "用户：" & Environ$("username") 

                With xMailItem 

                    .To = "收件人邮箱@example.com" 

                    .Subject = "【Excel提醒】任务到期提醒！" 

                    .Body = xMailBody 

                    .Display  '改为.Send 可自动发送 

                End With 

                Set xMailItem = Nothing 

                Set xOutApp = Nothing 

            End If 

        Next cell 

    End If 

    Application.DisplayAlerts = True 

    Application.ScreenUpdating = True 

End Sub

0 个注释