在满足条件时复制一行中的某些单元格，然后粘贴到新的 sheet

Question

我正在尝试复制行中的单元格 A:D，当列 E = "Accepted" 时，并将数据作为值粘贴到另一个 sheet 中。

但每次我尝试时，它只复制最后一行，我不明白为什么。如果有任何帮助，我将不胜感激。

我的代码如下所示：

Public Sub AcceptLastChangeRequest()

With Application
        .ScreenUpdating = False
        .EnableEvents = False
End With

On Error GoTo errorHandler:

    Dim varAnswer As String
        varAnswer = MsgBox("Are you sure you wish to accept the most recent Change Request?", vbYesNo, "Accept Change Request")
            If varAnswer = vbNo Then
                MsgBox ("No changes saved")
                    With Application
                        .ScreenUpdating = True
                        .EnableEvents = True
                    End With
                Exit Sub
            End If

    Dim SourceRange As Range, DestRange As Range
    Dim DestSheet As Worksheet, SourceSheet As Worksheet
    Dim LastRowDestSheet As Long, i As Long, LastRowSourceSheet As Long
        Set DestSheet = ThisWorkbook.Worksheets("Accepted Change Requests")
        Set SourceSheet = ThisWorkbook.Worksheets("All Change Requests")

            LastRowDestSheet = DestSheet.Cells(DestSheet.Rows.Count, "A").End(xlUp).Row
            LastRowSourceSheet = SourceSheet.Cells(SourceSheet.Rows.Count, "E").End(xlUp).Row

                For i = 2 To LastRowSourceSheet
                    If Sheets("All Change Requests").Range("E" & i).Value = "Accepted" Then
                        Set SourceRange = SourceSheet.Range("A" & i, "D" & i)
                        Set DestRange = DestSheet.Range("A" & LastRowDestSheet + 1)
                        SourceRange.Copy
                        DestRange.PasteSpecial _
                        Paste:=xlPasteValues, _
                        operation:=xlPasteSpecialOperationNone, _
                        skipblanks:=False, _
                        Transpose:=False

                        Application.CutCopyMode = False

                    End If
                Next i

            With Application
            .ScreenUpdating = True
            .EnableEvents = True
            End With

    Exit Sub

errorHandler:
MsgBox ("There was an error adding this Change Request")
Resume Next

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Answer 1

您没有更新目标的最后一行 sheet。

放

LastRowDestSheet = LastRowDestSheet + 1

在 if 子句的末尾（在 'Set DestRange = DestSheet.Range...' 之后）

Answer 2

尝试用这个替换你的循环：

For i = 2 To LastRowSourceSheet
   If SourceSheet.Range("E" & i).Value = "Accepted" Then _
     DestSheet.Range("A" & LastRowDestSheet + 1 & ":D" & LastRowDestSheet + 1).Value = _
         SourceSheet.Range("A" & i & ":D" & i).Value   
   LastRowDestSheet = LastRowDestSheet + 1
Next i

编辑 （进一步的 OP 请求）

For i = 2 To LastRowSourceSheet
   If SourceSheet.Range("E" & i).Value = "Accepted" Then
     If Evaluate("ISERROR(MATCH(A" & i & ",'Accepted Change Requests'!A:A,0))") Then 
         DestSheet.Range("A" & LastRowDestSheet + 1 & ":D" & LastRowDestSheet + 1).Value = _
            SourceSheet.Range("A" & i & ":D" & i).Value
         LastRowDestSheet = LastRowDestSheet + 1
     End If
   End If
Next i

在满足条件时复制一行中的某些单元格，然后粘贴到新的 sheet

Copying certain cells from a row, when criterea are met, and pasting into a new sheet

excel

vba