Question

因此，我创建了一个通过Outlook发送电子邮件的宏。我被困在某个时候。我需要在电子邮件正文的列顶部包括新的单元格值和相应的单元格值。所以基本上我需要我的宏才能读取这两个值。

这是我的模块：

Sub SendEmail()
    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")
        Dim olMail As Outlook.MailItem
        Set olMail = olApp.CreateItem(olMailItem)
        'So I want to send an email with cell new value and top of the column 
        'value corresponding to that cell
        'Example: I wanna change cell C3 from A to X and I want to include 
        'that change in body of my email automatically
        'So it reads "New cell value is X on 3-06"

        olMail.To = "*****@*****.com"
        olMail.Subject = "Look what has been changed"
            olMail.Body = "Hi" & vbNewLine & vbNewLine & _
            "New cell value is <Here is new cell value> on <Top of the column 
             of that cell value> " & vbNewLine & vbNewLine & _
            "BR"
        olMail.Send
End Sub

这是我的宏：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Target.Worksheet.Range("A3:AP3")) Is Nothing Then SendEmail
End Sub

这是我正在工作的工作表的一部分：

Answer 1

您面临的问题之一是Target可以是多个单元格，而一次Worksheet_Change的更改可以同时覆盖多个单元格，而不仅仅是一个单元格。您可以检查目标是否为一个像元大小，如果大小不超过1, 1，则什么也不做，但是您至少会放弃该更改或部分更改。

一种方法是保存更改的历史记录，即使更改一次在多个单元格中发送，也要发送电子邮件。

请牢记这一点，您应该创建一个包含最新更改的工作表，例如工作表历史记录表。

在您正在处理的工作表中，将其放置在工作表的代码部分中：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Target.Worksheet.Range("A3:AP3")) Is Nothing Then
        checkHistory Target.Worksheet.Range("A3:AP3")
    End If
End Sub

在同一工作簿的任何模块中，添加以下内容：

Sub checkHistory(rng As Range)
Dim wsHistory As Worksheet: Set wsHistory = ThisWorkbook.Sheets("History Sheet")
Dim arrData As Variant, arrHistory As Variant
Dim R As Long, C As Long
Dim bChanges As Boolean

arrData = rng.Offset(-2).Resize(3)
arrHistory = wsHistory.Range(rng.Offset(-2).Resize(3).Address)

Dim arrChanges() As String: ReDim arrChanges(LBound(arrData) To UBound(arrData), LBound(arrData, 2) To UBound(arrData, 2))

For C = LBound(arrData, 2) To UBound(arrData, 2)
    If arrData(3, C) <> arrHistory(3, C) Then
        arrChanges(3, C) = arrData(3, C)
        If Not bChanges Then bChanges = True
    End If
Next C

If bChanges Then
    Dim strNewVal As String, strHeading As String

    wsHistory.Range(rng.Offset(-2).Resize(3).Address) = arrData
    For C = LBound(arrChanges, 2) To UBound(arrChanges, 2)
        If arrChanges(3, C) <> "" Then
            strNewVal = strNewVal & ", " & arrChanges(3, C)  'new values
            strHeading = strHeading & ", " & arrData(1, C) 'heading
        End If
    Next C

    strNewVal = Right(strNewVal, Len(strNewVal) - 2)
    strHeading = Right(strHeading, Len(strHeading) - 2)

    SendEmail strNewVal, strHeading
End If
End Sub

Sub SendEmail(strNewVal As String, strHeading As String)
    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")
        Dim olMail As Outlook.MailItem
        Set olMail = olApp.CreateItem(olMailItem)

        olMail.To = "*****@*****.com"
        olMail.Subject = "Look what has been changed"
            olMail.Body = "Hi" & vbNewLine & vbNewLine & _
            "New cell value is " & strNewVal & " on " & strHeading & vbNewLine & vbNewLine & _
            "BR"
        olMail.Send
End Sub

使用上述方法，无论更改是否超过1个单元格或更多（以逗号分隔的值），您都将发送该电子邮件。

Answer 2

一些小变化：

Sub SendEmail(rng As Range)
    Dim olApp As Outlook.Application, c As Range, bdy

    If rng Is Nothing Then Exit Sub '<< nothing to report

    Set olApp = CreateObject("Outlook.Application")
        Dim olMail As Outlook.MailItem
        Set olMail = olApp.CreateItem(olMailItem)

        olMail.To = "*****@*****.com"
        olMail.Subject = "Look what has been changed"
        bdy = "Hi" & vbNewLine & vbNewLine

        'check each changed cell
        For Each c in rng.Cells             
            bdy = bdy & "New cell value is '" & c.Value & _
                  "' on " & c.EntireColumn.Cells(1).Value & _
                  vbNewLine & vbNewLine
        Next c  

        olMail.Body = bdy & vbNewLine & vbNewLine & "BR"
        olMail.Send
End Sub

事件处理程序：

Private Sub Worksheet_Change(ByVal Target As Range)
    SendEmail Application.Intersect(Target, Me.Range("A3:AP3"))
End Sub

读取单元格值

2 个答案: