Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Value = vbNullString Then Exit Sub If Intersect(Target, Columns("D:D")) Is Nothing Then Exit Sub Application.ScreenUpdating = False If Target.Value = "True" Then Target.EntireRow.Copy Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues Target.EntireRow.Delete End If Sheet2.Columns.AutoFit Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
DON'T MISS