在工作表之间宏传输数据时粘贴特殊要求

Question

我设置了一个宏，该宏将选定的行传输到Sheet2，以将信息传递给另一个部门。

这是一个共享的电子表格，并且在传递时，Sheet2上的宏重写条件格式存在问题。

任何人都可以帮助更改下面的宏以仅粘贴值，我希望不会覆盖工作表2上已应用的任何条件格式。

Sub Pass_to_xDepartment()

Application.EnableEvents = False
On Error GoTo Whoops

'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

'MsgBox when passing over work
If MsgBox("Do you want to pass the selected work to xDepartment?" & vbNewLine & vbNewLine & "Please ensure selected work is complete." & vbNewLine & vbNewLine & "This will generate an automatic email 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.Columns("N")).Value = Date

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

On Error Resume Next
Set sht3 = ActiveWorkbook.Sheets("temp")
On Error GoTo 0
If sht3 Is Nothing Then
    Set sht3 = ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
    sht3.Name = "temp"
Else
    sht3.UsedRange.Clear
End If
'Note: if the selection is one cell it will send the whole worksheet
Set Sendrng = sht2.Range("A" & (lastRow + 1) & ":N" & 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:N" & lastRow2)

With Sendrng

    ActiveWorkbook.EnvelopeVisible = True
    With .Parent.MailEnvelope

        ' Set the optional introduction field thats adds
        ' some header text to the email body.
        .Introduction = "Dear xDepartment," & vbNewLine & vbNewLine & "The following work has been completed." & vbNewLine & vbNewLine & "Please see the shared spreadsheet for further details." & vbNewLine & vbNewLine & "Kind regards," & vbNewLine & "yDepartment" & vbNewLine

        With .Item
            .To = "email"
            .CC = "email"
            .BCC = ""
            .Subject = "New work passed over from yDepartment"
            .Send
        End With

    End With
End With

StopMacro:

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
Worksheets("yDepartment").Activate
MsgBox ("Tours have been passed to xDepartment.")

Whoops:
 Application.EnableEvents = True

End Sub