Sub TransferData() Dim lr As Long Application.ScreenUpdating = False Sheet1.Range("A1", Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "X", 7 lr = Sheet1.Range("B" & Rows.Count).End(xlUp).Row If lr > 1 Then Sheet1.Range("B2", Sheet1.Range("E" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues Sheet2.Columns.AutoFit End If Sheet1.[A1].AutoFilter Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
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("A:A")) Is Nothing Then Exit Sub Application.ScreenUpdating = False If Target.Value = "X" Then Target.EntireRow.Copy Sheet2.Range("A" & Rows.Count).End(3)(2) End If Sheet2.Columns.AutoFit Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
If Target.Value = "YES" Then
If Target.Value <> "" Then
DON'T MISS
Have fun!
https://drive.google.com/file/d/0B8ZUqlS0WQfUV21PVVpyR2hJQWc/view?usp=sharing