Sub TransferData() Dim lr As Long Application.ScreenUpdating = False ActiveSheet.Columns("A").EntireColumn.Hidden = True ActiveSheet.Columns("F:I").EntireColumn.Hidden = True ActiveSheet.Columns("M:Z").EntireColumn.Hidden = True lr = Range("A" & Rows.Count).End(xlUp).Row Sheet2.UsedRange.Offset(1).ClearContents With ActiveSheet .AutoFilterMode = False With Range("B1", Range("B" & Rows.Count).End(xlUp)) .AutoFilter 1, "Phone Call", xlOr, "Digital Interaction" On Error Resume Next Range("B2:AB" & lr).Copy Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues End With .AutoFilterMode = False End With ActiveSheet.Columns("A").EntireColumn.Hidden = False ActiveSheet.Columns("F:I").EntireColumn.Hidden = False ActiveSheet.Columns("M:Z").EntireColumn.Hidden = False Sheet2.Columns.AutoFit Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Data transfer completed.", vbExclamation, "STATUS" End Sub
DON'T MISS