Cut/paste 单元格范围到另一个 sheet 并发送电子邮件

Question

下面有一些代码几乎完全符合我的要求。目前，我有两个 sheet，一个用于 Y 部门，一个用于 X 部门。我想要一个按钮将一系列单元格 (A:L) 从 Y 部门 sheet 传递到 X 部门 sheet。我不想粘贴整行，因为在 X 部门 sheet 中有来自 M-W 的公式，当我这样做时它们会被覆盖。

目前，这几乎可以正常工作。但它一次只能让我通过一行。是否可以编辑此代码，以便我一次可以 select 多行并将所有这些行剪切并粘贴（仅 A:L 的单元格）到 X 部门 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

'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
    Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row).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

另外，出于兴趣，你知道是否有办法设置这个按钮，以便它在传递数据的同时发送一封电子邮件，以便在行传递给 X 部门时通知 X 部门他们 sheet?不过这是次要问题。

Answer 1

我有一个宏，可以逐行复制所选范围并将其粘贴到下一个范围。也许它会有所帮助。

此外，如果您知道正在处理的行数，则可以随时执行

    Range(Ax:Lx).Select

如果没有，这可能会成功：

    Dim i As Integer
    i = 2 //1 if first row isn't headers. 
    Do While sht1.Range("A" & i).Value <> Empty
    sht1.Range("A" & i & "L" & i).Select
    Selection.Copy
    sht2.Range("A" & lastrow +1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    i = i + 1
    Loop

如果有帮助或需要调整，请告诉我。

Answer 2

一些建议，一些"must haves":

Avoid using Select in Excel VBA
显然 Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row) 只是一行，因为 ActiveCell 是单个单元格而不是单元格区域。如果要获取所选范围的 A 到 L 列，请使用 …
```
Selection.EntireRow.Resize(ColumnSize:=12) '= first 12 columns of selection
```
你所有的 Range 和 Cells 都应该用像 sht1.Range.
使用有意义的变量名称，例如将 sht1 替换为 wsSource，将 sht2 替换为 wsDestination，这会使您的代码更易于理解。
不要像 If MsgBox(…) = vbNo Then 那样测试您的消息框，而是测试 If Not MsgBox(…) = vbYes。否则按 window 右上角的 X 与按 Yes 按钮的效果相同。
确保你的意思是 ActiveWorkbook（= 有焦点的那个/在最上面）而不是 ThisWorkbook（= 这个代码是运行中）。
我建议激活 Option Explicit：在 VBA 编辑器中转到工具 › 选项 › Require Variable Declaration 并正确声明所有你的变量。

所以你最终会得到这样的结果：

Option Explicit

Public Sub Pass_to_Xdepartment()
    If Not MsgBox("Do you want to pass the selected tours to Xdepartment?", vbYesNo, "Pass to XDepartment") = vbYes Then
        Exit Sub
    End If

    Dim ws As Worksheet, DTable As ListObject
    For Each ws In ThisWorkbook.Worksheets
        If ws.AutoFilterMode Then
            If ws.FilterMode Then
                ws.ShowAllData
            End If
        End If
        For Each DTable In ws.ListObjects
            If DTable.ShowAutoFilter Then
                DTable.Range.AutoFilter
                DTable.Range.AutoFilter
            End If
        Next DTable
    Next ws

    Dim wsSrc As Worksheet
    Set wsSrc = ThisWorkbook.Worksheets("YDepartment")

    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Worksheets("XDepartment")

    Dim LastRow As Long
    LastRow = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row

    'Move row to destination sheet & Delete source row
    With Selection.EntireRow.Resize(ColumnSize:=12) '= A:L of the selected rows
        .Copy Destination:=wsDest.Cells(LastRow + 1, "A")
        .EntireRow.Delete
    End With
End Sub

根据评论编辑（写日期）：

既然你删除了复制的行，你可以先将日期写入 M 列

    Intersect(Selection.EntireRow, Selection.Parent.Columns("M")).Value = Date

然后复制A:M而不是A:L

    With Intersect(Selection.EntireRow, Selection.Parent.Range("A:M")) '= A:M of the selected rows
        .Copy Destination:=wsDest.Cells(LastRow + 1, "A")
        .EntireRow.Delete
    End With

Cut/paste 单元格范围到另一个 sheet 并发送电子邮件

Cut/paste range of cells into another sheet and send an email

excel

vba

commandbutton

excel-2016