Чтение значения ячейки

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

Некоторые небольшие изменения:

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

Answer 2

Одна из проблем, с которой вы сталкиваетесь, заключается в том, что 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 ячейку или более, в виде значений, разделенных запятыми.