CODEWITHSUNDEEP
vbaexcel
newishuser
newishuser

Reputation: 610

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

I'm trying to copy cells A:D from a row, when column E = "Accepted", and paste the data, as values, into a different sheet.

Every time I try though, it only copies the last row and I can't understand why. I'd be really grateful for any help.

My code looks like this: 

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

Upvotes: 0

Views: 87

Answers (2)

SierraOscar
SierraOscar

Reputation: 17647

Try replacing your loop with this: 

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

EDIT (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

Upvotes: 1

EngJon
EngJon

Reputation: 997

You are not updating the last row of the destination sheet.

Put

LastRowDestSheet = LastRowDestSheet + 1

in the end of the if-clause (after 'Set DestRange = DestSheet.Range...')

Upvotes: 3

Related Questions