复制和粘贴值，一次搜索所有内容，同时保留公式的

如何解决复制和粘贴值，一次搜索所有内容，同时保留公式的

这是一个非常新的知识，我很惊讶我已经走到了这么远，我能够看到我从另一个电子表格中获得的一些代码，所以在那里有些帮助，但是现在我有点卡住了。

以下是用于将值简单复制到另一张纸的代码，同时保持对所有内容的检查，就像它从其复制的原始纸中的公式一样。我将其链接到按钮，此方法的问题是

1. 我将不得不为此创建多个按钮并相应地编辑代码。

2. 当一切都很好时，如果我按了按钮以移动数据，那么如果我有很多行包含数据，我将不得不重复此过程多次。

理想情况下，我希望从下面获得类似的代码，但只需按下1个按钮，然后在每行J列中搜索“待处理”一词（如果该行具有“待处理”）即可。如果没有，请运行下面的代码。

我认为我已经解释了，好的，请让我知道或询问任何事情。再次对此非常新，因此请记住这一点，并希望代码显示正常。

预先感谢！

Sub CopySource()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
If Range("J1").Value = "Pending" Then
MsgBox "Result still set as 'Pending'. Not Complete."
Else
Dim rngSource As Range
Dim rngTarget As Range
Dim iRow As Integer

iRow = Worksheets("Sheet2").Cells(Rows.Count,1).End(xlUp).Row + 1
Worksheets("Sheet1").Range("A1:L1").Copy
Worksheets("Sheet2").Range("A" & iRow).PasteSpecial Paste:=xlPasteValues

Dim rConstants As Range

Set rConstants = Sheet1.Range("A1:L1").SpecialCells(xlCellTypeConstants)
rConstants.ClearContents
Range("J1").FormulaR1C1 = "Pending"

End If

Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

解决方法

尝试一下：

首先在当前工作簿的副本上使用它，以确保它不会做意外的事情。

Sub CopySource()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

Dim last As Long
Dim rngSource As Range
Dim rngTarget As Range
Dim iRow As Integer
Dim rConstants As Range

last = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To last
    If Range("J" & i).Value <> "Pending" Then
        iRow = Worksheets("Sheet2").Cells(Rows.Count,1).End(xlUp).Row + 1
        Worksheets("Sheet1").Range("A" & i & ":L" & i).Copy
        Worksheets("Sheet2").Range("A" & iRow).PasteSpecial Paste:=xlPasteValues
        Set rConstants = Sheet1.Range("A" & i & ":L" & i).SpecialCells(xlCellTypeConstants)
        rConstants.ClearContents
        Range("J" & i).FormulaR1C1 = "Pending"
    End If
Next i

Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

,

这是一种方法（为清楚起见，省略了优化）：

Sub CopySource()

    Dim c As Range,wsSrc As Worksheet,wsDest As Worksheet,rng As Range
    
    Set wsSrc = Worksheets("Sheet1")
    Set wsDest = Worksheets("Sheet2")
    
    For Each c In wsSrc.Range("J1:J" & wsSrc.Cells(Rows.Count,1).End(xlUp).Row).Cells
        If Not c.Value = "Pending" Then
            Set rng = c.EntireRow.Range("A1:L1") 'range is *relative* to the row...
            With wsDest.Cells(Rows.Count,1).End(xlUp).Offset(1,0)
                .Resize(1,rng.Columns.Count).Value = rng.Value
            End With
            rng.SpecialCells(xlCellTypeConstants).ClearContents
            c.Value = "Pending"
        End If
    Next c

End Sub