excelvba

How do you copy and paste entire row of source sheet to destination when a date appears in specific column?


I have a worksheet labeled "Key_Combination Management" (Source) that tracks revocation date in Column E:E. I would like to have the entire row that corresponds with that date to be copy and pasted to another worksheet labeled "Revoked Master List" (Destination) whenever a date is entered, then deleted from the source. The code I am currently using allows any time a cell in E:E has data entered to be copy, pasted and deleted. I want to limit to cells that have dates in them.

This is what I am currently using. I am not sure how to make it only execute on cells with dates in E:E on the source sheet.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("E:E")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    If Target.Range("E:E") Then
        With Target.EntireRow
        .Copy Sheets("Revoked Master List").Cells(Sheets("Revoked Master List").Rows.Count, 1).End(xlUp).Offset(1, 0)
        .Delete
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End If
End Sub

Solution

  • Here's one way to handle it:

    Private Sub Worksheet_Change(ByVal Target As Range)
        Dim rng As Range, c As Range, v, ws As Worksheet, rngDel As Range
        
        Set rng = Application.Intersect(Target, Me.Range("E:E"))
        If rng Is Nothing Then Exit Sub
        
        On Error GoTo haveError 'make sure events are not left disabled if there's an error
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        Set ws = ThisWorkbook.Worksheets("Revoked Master List")
        For Each c In rng.Cells        'handling multi-cell updates
            If IsDate(c.Value) Then    'cell has date ?
                c.EntireRow.Copy ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
                BuildRange rngDel, c 'add cell to "delete" range
            End If
        Next c
        'any copied rows to delete?
        If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
        
    haveError:
        If Err <> 0 Then Debug.Print Err.Description
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub
    
    'Add range `rngAdd` to range `rngTot`
    Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
        If rngTot Is Nothing Then
            Set rngTot = rngAdd
        Else
            Set rngTot = Application.Union(rngTot, rngAdd)
        End If
    End Sub
    

    Added - if both source and destination are listobjects then this would work to transfer the rows:

    Private Sub Worksheet_Change(ByVal Target As Range)
        Dim rng As Range, c As Range, v, ws As Worksheet, rngDel As Range
        Dim tblSrc As ListObject, tblDest As ListObject
        
        Set tblSrc = Me.ListObjects("SourceTable") 'for example
        
        'has a change occurred in the "RevokeDate" column?
        Set rng = Application.Intersect(Target, _
                  tblSrc.ListColumns("RevokeDate").DataBodyRange)
        
        If rng Is Nothing Then Exit Sub 'nothing to handle
        
        On Error GoTo haveError 'make sure events are not left disabled if there's an error
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        'or use list name: the table to append to
        Set tblDest = ThisWorkbook.Worksheets("Revoked Master List").ListObjects(1)
        
        For Each c In rng.Cells        'handling multi-cell updates
            If IsDate(c.Value) Then    'cell has date ?
                Application.Intersect(c.EntireRow, tblSrc.DataBodyRange).Copy _
                   tblDest.ListRows.Add().Range
                BuildRange rngDel, c 'add cell to "delete" range
            End If
        Next c
        'any copied rows to delete?
        If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
        
    haveError:
        If Err <> 0 Then Debug.Print Err.Description
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub
    
    'Add range `rngAdd` to range `rngTot`
    Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
        If rngTot Is Nothing Then
            Set rngTot = rngAdd
        Else
            Set rngTot = Application.Union(rngTot, rngAdd)
        End If
    End Sub
    

    It's best to delete all copied rows at the end, and not one by one as you copy them.