Question

我正在使用下面的宏，当按下命令按钮时，该宏会将选定的行转移到新的工作表中，并将其从原始工作表中删除。

我正在尝试让它在运行此宏时发送自动电子邮件，以通知xDepartment yDepartment已经转移了工作。我希望电子邮件的正文包含正在传输的全部活动行。

此刻，当转移行时，我可以单击yDepartment工作表中该行（相邻和不相邻）中的任何单元格，它将A：L列传输到xDepartment工作表。但是，当我添加宏以发送电子邮件时，它只会发送我选择的特定单元格的详细信息，而不是完整行。

此外，如果单元格不相邻（例如，我要同时传输第4-5行和第8-10行），则会发送整张工作表，这是我不想要的。

有人知道我该如何解决，以便在转移工作时，自动电子邮件包含与转移的内容相同的内容？

谢谢！

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。

注意：传输数据后，代码稍有重新排列以发送电子邮件。

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

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所有变量也是一种好习惯，但这不是必需的

祝你好运

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

1 个答案: