0
Sub CopyRow()
'Declare variables
    Dim sheetNo1 As Worksheet
    Dim sheetNo2 As Worksheet
    Dim FinalRow As Long
    Dim Cell As Range
    
'Set variables
    Set sheetNo1 = Sheets("EA Log")
    Set sheetNo2 = Sheets("Commitments")
' Define destination sheets to move row
    FinalRow1 = sheetNo2.Range("A4:A" & sheetNo2.Rows.Count).End(xlUp).Row
'Apply loop for column P until last cell with value
    For Each Cell In sheetNo1.Range("P4:P" & sheetNo1.Cells(sheetNo1.Rows.Count, "P").End(xlUp).Row)
'Apply condition to match the "Signed" value
        If Cell.Value = "Signed" Then
'Command to Copy and move to a destination Sheet "Commitments"
            sheetNo1.Range(Cells(Cell.Row, 2), Cells(Cell.Row, 3)).Copy _
                        Destination:=sheetNo2.Range("A4:A" & FinalRow1 + 1)
                        
            sheetNo1.Range(Cells(Cell.Row, 14), Cells(Cell.Row, 25)).Copy _
                        Destination:=sheetNo2.Range("C4:C" & FinalRow1 + 1)
                        
            sheetNo1.Range(Cells(Cell.Row, 1)).Copy _
                        Destination:=sheetNo2.Range("E4:E" & FinalRow1 + 1)
                        
            FinalRow1 = FinalRow1 + 1
        End If
    Next Cell
End Sub
Warcupine
  • 4,460
  • 3
  • 15
  • 24

0 Answers0