Sub FollowUp() Dim ws As Worksheet Application.ScreenUpdating = False Sheet1.UsedRange.Offset(1).ClearContents For Each ws In Worksheets If ws.Name <> "Follow Up" Then With ws.[A1].CurrentRegion .AutoFilter 7, "Follow Up", , , 7 .Offset(1).EntireRow.Copy Sheet1.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues .AutoFilter End With End If Next ws Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Columns("G:G")) Is Nothing Then Exit Sub If Target.Count > 1 Then Exit Sub If Target.Value = "Complete" Then Target.EntireRow.Delete End If End Sub
Sub FollowUp() Dim ws As Worksheet Application.ScreenUpdating = False Sheet1.UsedRange.Offset(8).ClearContents For Each ws In Worksheets If ws.Name <> "Follow Up" Then With ws.[A8].CurrentRegion .AutoFilter 7, "Follow Up", , , 7 .Offset(1).EntireRow.Copy Sheet1.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues .AutoFilter End With End If Next ws Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
DON'T MISS