Help cleaning up a macro

I have a macro that works, but it takes a while to get the job done and the screen also flashes constantly as it runs. The macro finds all 0's or 1's in a specific column and then copies the entire row if a 0 or 1 is found. It then pastes all of the rows into a new worksheet, which is exactly what I want it to do. Here's the code:

Sub MoveForZeroorOne()

    Dim DataSheetName As String
    Dim ExceptionSheetName As String
    Dim MsgBoxResponse As Integer
    Dim Col4Value As Integer
    Dim CopyRange As String
    Dim Check4Data As Integer
    
    DataSheetName = "DATA"    '' Put your sheet name Here
    ExceptionSheetName = "EXCEPTIONS"   '' Put the sheet name where it should be copied too
    Col4Value = 3  '' Put your column that you are checking for 0 or 1
    CopyRange = "A1:C1"  '' This defines what you want to copy the 1 is the row number but is a reference used later
    
    MsgBoxResponse = MsgBox("Did you first move the cursor on your Data sheet where you want to start", vbYesNo, "Starting Position on Data Sheet")
    
    If MsgBoxResponse = 6 Then
       MsgBoxResponse = MsgBox("Did you first move the cursor on your Exception sheet where you want to put the data (Blank Line)", vbYesNo, "Starting Position on Data Sheet")
       If MsgBoxResponse = 6 Then
          Sheets(DataSheetName).Select
          ActiveCell.Offset(0, 1 - ActiveCell.Column).Activate
          While ActiveCell.Row <= Cells.SpecialCells(xlCellTypeLastCell).Row
                If ActiveCell.Offset(0, Col4Value - 1).Value >= 0 And ActiveCell.Offset(0, Col4Value - 1).Value <= 1 Then
                                      
                   Check4Data = 0
                   
                   ActiveCell.Range(CopyRange).Select
                   For Each cell In Selection
                      Check4Data = Check4Data + Len(cell.Value)
                   Next
                   If Check4Data > 0 Then
                      Selection.Copy
                      Sheets(ExceptionSheetName).Select
                      ActiveSheet.Paste
                      ActiveCell.Offset(1, 0).Activate
                      Sheets(DataSheetName).Select
                      Application.CutCopyMode = False
                   End If
                End If
                ActiveCell.Offset(1, 0).Activate
          Wend
       End If
    End If
    If MsgBoxResponse = 7 Then
       MsgBox "Move your cursor to the starting points on the sheets then restart the macro", vbOKOnly
    End If
End Sub

If there is any way this could be cleaned up so it can complete the job quicker and without the screen blinking, it would be greatly appreciated if you would give me your insights!!