Макрос Excel - автоматическая отправка электронной почты при переносе данных с одного листа на другой (копирование полной строки)

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 все ваши переменные в начале ваших программ, но не обязательно

Удачи