How to keep data validation error message shownWhen copy and paste value fromAnother file?

[yl41012]

I have a spreadsheet with lots of columns with drop-down menus from data validation. When someone enters a value different than one of the values from the drop-down menu, Excel will show an error message saying the input has to be as the same as one of the drop-down menu choices. This works well when people type a value to a cell. However, if they copy and paste a value from another spreadsheet, the error message is not shown. For example, for Current Status (column J) in the attached spreadsheet, there are three answer choices from the drop-down menu: Still active, Graduated, and Left without graduation. When I copied and pasted the text "Unknown" from another spreadsheet to J4, no error message is shown. I know that J4 will be circled if I click Circle Invalid Data under Data Validation. However, I want something that will force update of J4. Is there a way to keep the original validation when people copy and paste?

BTW, I have the code below under VBA and I need the code to still function after making the error message shown.

Thank you very much in advance!

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim rngCell As Range, strBlanks As String

    strBlanks = vbNullString
    For Each rngCell In Sheet1.Range("B2:B238").Cells
        If Len(Trim(rngCell.Value)) > 0 Then
            If WorksheetFunction.CountA(rngCell.Offset(0, 2).Resize(1, 2)) < 2 Then
                strBlanks = strBlanks & IIf(Len(strBlanks) > 0, ",", "") & Replace(rngCell.Offset(0, 2).Resize(1, 2).SpecialCells(xlCellTypeBlanks).Address, "$", "")
            End If
            
            If rngCell.Offset(0, 5).Value = "" Then
                strBlanks = strBlanks & IIf(Len(strBlanks) > 0, ",", "") & Replace(rngCell.Offset(0, 5).Address, "$", "")
            End If
                       
            
            If WorksheetFunction.CountA(rngCell.Offset(0, 7).Resize(1, 3)) < 3 Then
                strBlanks = strBlanks & IIf(Len(strBlanks) > 0, ",", "") & Replace(rngCell.Offset(0, 7).Resize(1, 3).SpecialCells(xlCellTypeBlanks).Address, "$", "")
            End If
            
            
            If rngCell.Offset(0, 8).Value = "Graduated" Then
                If rngCell.Offset(0, 11).Value = "" Then
                   strBlanks = strBlanks & IIf(Len(strBlanks) > 0, ",", "") & Replace(rngCell.Offset(0, 11).Address, "$", "")
                End If
            End If
            
            If rngCell.Offset(0, 8).Value = "Left without Graduation" Then
                If rngCell.Offset(0, 11).Value = "" Then
                   strBlanks = strBlanks & IIf(Len(strBlanks) > 0, ",", "") & Replace(rngCell.Offset(0, 11).Address, "$", "")
                End If
            End If
            
            If rngCell.Offset(0, 8).Value = "Graduated" Then
                If rngCell.Offset(0, 14).Value = "" Then
                   strBlanks = strBlanks & IIf(Len(strBlanks) > 0, ",", "") & Replace(rngCell.Offset(0, 14).Address, "$", "")
                End If
            End If
            
            If rngCell.Offset(0, 14).Value = "Other, specify" Then
               If rngCell.Offset(0, 15).Value = "" Then
                   strBlanks = strBlanks & IIf(Len(strBlanks) > 0, ",", "") & Replace(rngCell.Offset(0, 15).Address, "$", "")
               End If
            End If

            
            
            
        End If
    

    Next rngCell

    If Not strBlanks = vbNullString Then
        MsgBox "Entries Required In Cells " & vbCrLf & vbCrLf & strBlanks
        Cancel = True
        Exit Sub
    End If
    
    
    
End Sub