Excel 宏 - 将数据从一个 sheet 传输到另一个时自动发送电子邮件（复制整行）

Question

我正在处理下面的宏，它将选定的行传输到新的 sheet 并在按下命令按钮时将其从原始 sheet 中删除。

我试图让它在 运行 这个宏时自动发送电子邮件通知 xDepartment yDepartment 已经转移工作。我希望电子邮件的正文完整包含正在传输的活动行。

目前，在转移行时，我可以点击 yDepartment worksheet 行中的任何单元格（相邻和不相邻），它会将列 A:L 转移到x部门工作sheet。但是当我添加宏也发送电子邮件时，它只会发送我选择的特定单元格的详细信息，而不是整行。

此外，如果单元格不相邻（例如，我同时传输第 4-5 行和第 8-10 行），它会发送整个 sheet，这是我不想要的.

有谁知道如何解决这个问题，以便在转移工作时，自动发送的电子邮件包含与转移的内容相同的内容？

提前致谢！

Sub Pass_to_xDepartment()

If MsgBox("Do you want to pass the selected tours to XDepartment?", vbYesNo, "Pass to XDepartment") = vbNo Then Exit Sub

For Each WSheet In ActiveWorkbook.Worksheets
        If WSheet.AutoFilterMode Then
            If WSheet.FilterMode Then
                WSheet.ShowAllData
            End If
        End If
        For Each DTable In WSheet.ListObjects
            If DTable.ShowAutoFilter Then
                DTable.Range.AutoFilter
                DTable.Range.AutoFilter
            End If
        Next DTable
    Next WSheet

   Dim Sendrng As Range

    On Error GoTo StopMacro

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Note: if the selection is one cell it will send the whole worksheet
    Set Sendrng = Selection

    'Create the mail and send it
    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "The following rows have been completed. "

            With .Item
                .To = "EMAIL"
                .CC = 
                .BCC = ""
                .Subject = "Updated"
                .Send
            End With

        End With
    End With

StopMacro:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ActiveWorkbook.EnvelopeVisible = False

'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim lastRow As Long

'Set variables
    Set sht1 = Sheets("YDepartment")
    Set sht2 = Sheets("XDepartment")

'Select Entire Row.Resize(ColumnSize:=12)
    Intersect(Selection.EntireRow, Selection.Parent.Range("A:L")).Select

'Move row to destination sheet & Delete source row
    lastRow = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row

    With Selection
        .Copy Destination:=sht2.Range("A" & lastRow + 1)
        .EntireRow.Delete
    End With

End Sub

Answer 1

为了发送整行的详细信息，您可以通过范围选择其内容来设置 Sendrng 变量，而不是将其分配给 selection。

注意：为了使其正常工作，在传输数据后将代码稍作重新安排以发送电子邮件。

这也应该补偿选择不同的范围并希望避免发送整个 sheet。

Sub Pass_to_xDepartment()

    'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim lastRow As Long
    Dim lastRow2 As Long
    Dim WSheet As Variant
    Dim DTable As Variant
    Dim Sendrng As Range
    Dim sht3 As Worksheet

    If MsgBox("Do you want to pass the selected tours to XDepartment?", vbYesNo, "Pass to XDepartment") = vbNo Then Exit Sub

    For Each WSheet In ActiveWorkbook.Worksheets
        If WSheet.AutoFilterMode Then
            If WSheet.FilterMode Then
                WSheet.ShowAllData
            End If
        End If
        For Each DTable In WSheet.ListObjects
            If DTable.ShowAutoFilter Then
                DTable.Range.AutoFilter
                DTable.Range.AutoFilter
            End If
        Next DTable
    Next WSheet

    'Set variables
    Set sht1 = Sheets("YDepartment")
    Set sht2 = Sheets("XDepartment")

    'Move row to destination sheet & Delete source row
    lastRow = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row

    'Select Entire Row.Resize(ColumnSize:=12)
    Intersect(Selection.EntireRow, Selection.Parent.Range("A:L")).Select

    With Selection
        .Copy Destination:=sht2.Range("A" & lastRow + 1)
        lastRow2 = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
        .EntireRow.Delete
    End With

    Set sht3 = ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
    sht3.Name = "temp"
    'Note: if the selection is one cell it will send the whole worksheet
    Set Sendrng = sht2.Range("A" & (lastRow + 1) & ":L" & lastRow2)
    Sendrng.Copy Destination:=sht3.Range("A1")

 On Error GoTo StopMacro

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Create the mail and send it
    sht3.Activate
    lastRow2 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row
    Set Sendrng = sht3.Range("A1:L" & lastRow2)

    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "The following rows have been completed. "

            With .Item
                .To = "EMAIL"
                .CC = ""
                .BCC = ""
                .Subject = "Updated"
                .Send
            End With

        End With
    End With

StopMacro:

    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("temp").Delete
    Application.DisplayAlerts = True

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ActiveWorkbook.EnvelopeVisible = False

End Sub

此外，最好在程序顶部声明或Dim所有变量，但不是必需的

祝你好运