Limit characters in cells with VBA and require action

I have a column that I need to limit text to 40 characters in each cell. I can't use validation because data will be pasted in. I have the following code that almost works, but I need the message to keep coming up until the problem is fixed in any one cell. Right now, as soon as you enter, tab or click off the cell the message comes up, but you can click ok and then go on to other things without fixing the problem. I need them to fix the problem before moving on to anything else on the worksheet.

Here is what I have so far:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell    As Excel.Range
     
    If Not Intersect(Target, Columns("A")) Is Nothing Then
        For Each cell In Intersect(Target, Columns("A"))
            If Len(cell.Value) > 40 Then
                 cell.Select
                 MsgBox "Cell cannot contain over 40 character, please shorten description"
            End If
        Next cell
    End If
End Sub

Edit: Didn't see you couldnt use validation

This will prompt for the corrected description in a popup box, it will present the first 40 characters as a default so you could just press ENTER to truncate.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range

    If Not Intersect(Target, Columns("A")) Is Nothing Then
        For Each cell In Intersect(Target, Columns("A"))
            If Len(cell.Value) > 40 Then
                 cell.Select
                 Do
                    cell.Value = Application.InputBox("This cell cannot contain over 40 character, please shorten description", _
                        "Shorten this description", Left(cell, 40), Type:=2)
                    If Len(cell) <= 40 Then Exit Do
                Loop
            End If
        Next cell
    End If
End Sub

If you do not shorten it or enter another value still too long, it will loop until you do.

You might want to just have the cell value truncated and get a "beep" to indicate it happened.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range

If Not Intersect(Target, Columns("A")) Is Nothing Then
    For Each cell In Intersect(Target, Columns("A"))
        If Len(cell.Value) > 40 Then
            cell.Value = Left(cell, 40)
            Beep
        End If
    Next cell
End If
End Sub

How about this:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, MyStr As String, Ans As String

If Not Intersect(Target, Columns("A")) Is Nothing Then
    For Each cell In Intersect(Target, Columns("A"))
        If Len(cell.Value) > 40 Then
             MyStr = cell
             Do
                Ans = Application.InputBox("This cell cannot contain over 40 character, please shorten description", _
                    "Shorten this description", MyStr, Type:=2)
                If Ans = "False" Then
                    'Loop will restart
                ElseIf Len(Ans) <= 40 Then
                    cell = Ans
                    Exit Do
                Else
                    MyStr = Ans
                End If
            Loop
        End If
    Next cell
End If

End Sub