Question

下面，我有一些代码几乎可以完全按照我的意愿工作。目前，我有两张纸，一张用于Y部门，一张用于X部门。我想要一个按钮，以将一系列单元格（A：L）从Y部门表传递到X部门表。我不想粘贴整行，因为X部门工作表中有来自M-W的公式，当我这样做时这些公式会被覆盖。

目前，这几乎可行。但这只能让我一次通过一行。是否可以编辑此代码，以便一次选择一个以上的行，并且它将所有这些行（仅对A：L单元格进行粘贴）粘贴并粘贴到X部门工作表上？

谢谢！

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部门？这是次要的问题。

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

一些建议，一些“必须拥有” ：

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。否则，按下窗口右上角的 X 与按是按钮具有相同的效果。
请确保您的意思是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

将范围内的单元格剪切/粘贴到另一张表格中并发送电子邮件

2 个答案: