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
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.