简体   繁体   中英

Check a range of cells and if criteria is met message box appears and undos action

I'm trying to verify a range of cells from M31:M41 and if the cells are grey and a user enters in information by mistake, then a message box appears and then the last action is undone. Here's my code so far

Set rng = ThisWorkbook.Sheets("Edit Entry").Range("M31:M41")

For each cell in rng 
    If cell.interior.Colorindex = 15 then 
        If Not Intersect(Target, Range("M31:M41")) Is Nothing then 
            Msgbox "NOT AN EDITABLE FIELD.", vbCritical + vbOkOnly, "NO DATA ENTRY"

            With Application 
                .EnableEvents = False 
                .Undo 
                .EnableEvents = True 
            End With 
        End If 
    End If 
Next Cell

The issue, is that it works how I want it to but it gives me the error

Run-Time error '1004': Method 'Undo' of object' _Application' Failed.

Any ideas on how to achieve this without any coding issues?

This seems to work for me for a single cell....

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRange As Range
Set myRange = Range("M31:M41")

If Not Intersect(Target, myRange) Is Nothing Then
    If Target.Interior.Color = 15 Then
        Application.EnableEvents = False
            MsgBox "Cannot Change This Cell"
            Application.Undo
        Application.EnableEvents = True
    End If
End If

End Sub

And for a multi-ranged change...

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRange As Range, xCell As Range
Set myRange = Range("M31:M41")

For Each xCell In Target
    If Not Intersect(xCell, myRange) Is Nothing Then
        If xCell.Interior.Color = 15 Then
            Application.EnableEvents = False
                MsgBox "Cannot Change This Cell"
                Application.Undo
            Application.EnableEvents = True
            Exit Sub
        End If
    End If
Next xCell

End Sub

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM