复制行中的某些单元格，满足criterea时，粘贴到新表中

Question

我尝试从列中复制单元格A：D，当列E =“接受”时，并将数据粘贴为值，放到另一张纸上。

虽然每次我尝试，但它只复制最后一行，我不明白为什么。我会很感激任何帮助。

我的代码如下所示：

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

你没有更新的目标表的最后一排。

将

LastRowDestSheet = LastRowDestSheet + 1 

在if子句结束（在 '设置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 

---

编辑（Further OP request）

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