Msbox VBA code when cell value is changed

R

Ramadan2512

New Member
Joined
Sep 7, 2024
Messages
40
Office Version
  1. 2021
Platform
  1. Windows
I'm stuck with a part of long VBA code in my worksheet to pop up Msgbox in case if cell vlaue was edited - here is the probelm
I have a worksheet that collect data from other sheet with formulas to show me the employee records and ID image when I only insert the employee ID number in Cell "E5: or "G5" so I want to protect all the sheet cells starting from ("B7:N45") for not letting user to change my formulas but when I make it with protect sheet the vba code doesn't work properly so I added a part in my vba code to alert the user not to write anything in these cells and only to insert ID number in ( E5 or G5) like this
VBA Code: 
[/
 If Not (Application.Intersect(Range("B7:N45"), Target) Is Nothing) Then
      MsgBox "Please don't change the cell and only insert ID in E5 or G5", vbInformation, "Pop Up Message"
   End If
End Sub]


the problem is when I add a new number in E5 or G5 the data in the rest of sheet between (B7:N45) of couser change according to the formula in each cell and the code consider this as edit and mxgbox pop up also while i need it tp pop up only if user override the formula or exisitng cell value

So, I need please: first if there is a way in the code to stop user write anything in this sheet in range (B7:N45) unless he selected for example edit anyway or something like that
second: if first not possible so please to edit my part of vba code to ignore the data changed through formula and to pop up only if inserted by user
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
You can do it as follows:
1. Select all the excel cells and lock the cells in Format Cells / Protection / Check Locked
1729339972254.png


2. Select the cells that you will be able to edit, for example E5 to G5 and remove the lock (Format Cells / Protection / UnCheck Locked)

3. Protect the sheet, but uncheck the "Select locked cells" option and press OK
1729340341618.png


Note: The code with the intersect is no longer necessary.

---------
Ramadan2512 said:
but when I make it with protect sheet the vba code doesn't work
Click to expand...
Which code are you referring to?

If you have other code that works on the sheet, then at the beginning of the code you unprotect the sheet and at the end of the code you protect the sheet again, example:

VBA Code: 
Sub MacroTest()
  ActiveSheet.Unprotect "abc"
  
  'here your code
  
  ActiveSheet.Protect "abc"
  ActiveSheet.EnableSelection = xlUnlockedCells
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --
 
Upvote 0
DanteAmor said:
You can do it as follows:
1. Select all the excel cells and lock the cells in Format Cells / Protection / Check Locked
View attachment 118279

2. Select the cells that you will be able to edit, for example E5 to G5 and remove the lock (Format Cells / Protection / UnCheck Locked)

3. Protect the sheet, but uncheck the "Select locked cells" option and press OK
View attachment 118280

Note: The code with the intersect is no longer necessary.

---------

Which code are you referring to?

If you have other code that works on the sheet, then at the beginning of the code you unprotect the sheet and at the end of the code you protect the sheet again, example:

VBA Code: 
Sub MacroTest()
  ActiveSheet.Unprotect "abc"
 
  'here your code
 
  ActiveSheet.Protect "abc"
  ActiveSheet.EnableSelection = xlUnlockedCells
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Click to expand...
Thanks for your reply but As I said in my question, when i use protect sheet the vba code doesn't run properly - I have a long code performing alot of tasks
 
Upvote 0
Set
VBA Code: 
Application.Calculate = xlManual
at the proper place in you code to prevent formulas from calculating until you want them to.
 
Upvote 0
Ramadan2512 said:
when i use protect sheet the vba code doesn't run properly
Click to expand...
As I said in post #2, which code are you referring to?

If the sheet is protected and your code wants to write to the sheet, then you must first unprotect the sheet, continue with your code and at the end, protect the sheet again.

Put your code here and I'll help you adapt it to work with the protected sheet. 😇
 
Upvote 0
Without protecting the sheet, try using Worksheet_Change event, like this:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
'Put this code in the sheet code module, this is how:
'Copy the code > open the sheet > Right-click the sheet tab >> View Code >> paste the code into the code window

    If Not Intersect(Target, Range("B7:N45")) Is Nothing Then
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
            MsgBox "Please don't change the cell and only insert ID in E5 or G5", vbInformation, "Pop Up Message"

    End If
End Sub
 
Upvote 0
Skyybot said:
Set
VBA Code: 
Application.Calculate = xlManual
at the proper place in you code to prevent formulas from calculating until you want them to.
Click to expand...
of course I want formulas to work normally as soon as i add ID number in E5 or G5
 
Upvote 0
DanteAmor said:
As I said in post #2, which code are you referring to?

If the sheet is protected and your code wants to write to the sheet, then you must first unprotect the sheet, continue with your code and at the end, protect the sheet again.

Put your code here and I'll help you adapt it to work with the protected sheet. 😇
Click to expand...
here is my full code and for your kind info the sheet in not protected because when i protect it the code don't work properly


VBA Code: 
[/
Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet
    path = "D:\Desktop\Guards\Guards National IDs\"
    'The array below contains picture shape names, condition ranges (numbers in which correlate to picture file names), and add-to ranges
    a = [{"picture1","E5","D44"; "picture2","G5","J44"}] 'Create a 2x3/multidimensional array using the Application.Evaluate [] shortcut.

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then 'consider using If Not Intersect(Target, Range("E5,G5") or Range("E5:G5")) Is Nothing Then...with other changes in the code if you want to change multiple conditions in one swoop
            ws.Range("D11").NumberFormat = "[$-,200]yyyy\/m\/d;@"
            ws.Range("D11").Value = ThisWorkbook.BuiltinDocumentProperties("Last Save time")
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " (Del old if exists, Add the new: " & a(r, 1) & " into cell: " & a(r, 3) & ")"
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " (Adding the new " & a(r, 1) & ")"
                path = picPath(path, ws.Range(a(r, 2)).Value)
                If Len(path) < 2 Then Exit Sub 'either the path is invalid or the picture file which name contains ws.Range(a(r, 1)).Value wasn't found
                If ws.Range(a(r, 3)).MergeCells Then
                    Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, _
                        ws.Range(ws.Range(a(r, 3)).MergeArea.Address).Width, ws.Range(ws.Range(a(r, 3)).MergeArea.Address).Height)
                Else
                    Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, _
                        ws.Range(a(r, 3)).Width, ws.Range(a(r, 3)).Height) '-1,-1 simply uses the picture's original Width and Height respectively
                End If
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " (Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3) & ")"
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
'                ws.Range(a(r, 3)).ClearContents 'uncomment if you want clear the existing contents in cells D44, J44
                Exit For
            End If
        End If
    Next
    If Not (Application.Intersect(Range("B7:O45"), Target) Is Nothing) Then
      MsgBox "Please don't write anything in this page, just put the permit number and print", vbInformation, "Pop Up Message"
   End If
End Sub

Function picPath(path, picNum As Variant) As String
    Dim fso, file, files, folder As Object
    Set fso = CreateObject("Scripting.FileSystemObject") 'consider using dir() instead of fso
    Debug.Print "  [searching for a picture which name contains: " & picNum & " in path: " & path & "]"
    If fso.FolderExists(path) Then 'Path is valid/folder exists
        Set folder = fso.GetFolder(path)
        Set files = folder.files
        If files.Count = 0 Then 'Folder is empty
            Debug.Print "  [(exiting sub): 0 files in " & path & "]"
            picPath = 0: Exit Function 'return 0
        End If
        For Each file In files
            Debug.Print "   [(found the following file: " & file.Name & " in " & path & ")]"
            If InStr(file.Name, picNum) Then 'InStr(look_inside, look_for)
                Debug.Print "  [(success): found a picture which name contains: " & picNum & " in " & path & "]"
                picPath = file.path: Exit Function 'return picture's path
            End If
        Next
    Else
        Debug.Print "  [(exiting sub): [(exiting sub): there is a syntax error in the path or the directory/folder doesn't exist, path: " & path & "]"
        picPath = 0: Exit Function 'return 0
    End If
End Function

  

]
 
Last edited:
Upvote 0
Akuini said:
Without protecting the sheet, try using Worksheet_Change event, like this:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
'Put this code in the sheet code module, this is how:
'Copy the code > open the sheet > Right-click the sheet tab >> View Code >> paste the code into the code window

    If Not Intersect(Target, Range("B7:N45")) Is Nothing Then
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
            MsgBox "Please don't change the cell and only insert ID in E5 or G5", vbInformation, "Pop Up Message"

    End If
End Sub
Click to expand...
I did but the cide stopped working here is my full code I have

VBA Code: 
[/
Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet
    path = "D:\Desktop\Guards\Guards National IDs\"
    'The array below contains picture shape names, condition ranges (numbers in which correlate to picture file names), and add-to ranges
    a = [{"picture1","E5","D44"; "picture2","G5","J44"}] 'Create a 2x3/multidimensional array using the Application.Evaluate [] shortcut.

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then 'consider using If Not Intersect(Target, Range("E5,G5") or Range("E5:G5")) Is Nothing Then...with other changes in the code if you want to change multiple conditions in one swoop
            ws.Range("D11").NumberFormat = "[$-,200]yyyy\/m\/d;@"
            ws.Range("D11").Value = ThisWorkbook.BuiltinDocumentProperties("Last Save time")
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " (Del old if exists, Add the new: " & a(r, 1) & " into cell: " & a(r, 3) & ")"
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " (Adding the new " & a(r, 1) & ")"
                path = picPath(path, ws.Range(a(r, 2)).Value)
                If Len(path) < 2 Then Exit Sub 'either the path is invalid or the picture file which name contains ws.Range(a(r, 1)).Value wasn't found
                If ws.Range(a(r, 3)).MergeCells Then
                    Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, _
                        ws.Range(ws.Range(a(r, 3)).MergeArea.Address).Width, ws.Range(ws.Range(a(r, 3)).MergeArea.Address).Height)
                Else
                    Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, _
                        ws.Range(a(r, 3)).Width, ws.Range(a(r, 3)).Height) '-1,-1 simply uses the picture's original Width and Height respectively
                End If
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " (Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3) & ")"
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
'                ws.Range(a(r, 3)).ClearContents 'uncomment if you want clear the existing contents in cells D44, J44
                Exit For
            End If
        End If
    Next
    If Not (Application.Intersect(Range("B7:O45"), Target) Is Nothing) Then
      MsgBox "Please don't write anything in this page, just put the permit number and print", vbInformation, "Pop Up Message"
   End If
End Sub

Function picPath(path, picNum As Variant) As String
    Dim fso, file, files, folder As Object
    Set fso = CreateObject("Scripting.FileSystemObject") 'consider using dir() instead of fso
    Debug.Print "  [searching for a picture which name contains: " & picNum & " in path: " & path & "]"
    If fso.FolderExists(path) Then 'Path is valid/folder exists
        Set folder = fso.GetFolder(path)
        Set files = folder.files
        If files.Count = 0 Then 'Folder is empty
            Debug.Print "  [(exiting sub): 0 files in " & path & "]"
            picPath = 0: Exit Function 'return 0
        End If
        For Each file In files
            Debug.Print "   [(found the following file: " & file.Name & " in " & path & ")]"
            If InStr(file.Name, picNum) Then 'InStr(look_inside, look_for)
                Debug.Print "  [(success): found a picture which name contains: " & picNum & " in " & path & "]"
                picPath = file.path: Exit Function 'return picture's path
            End If
        Next
    Else
        Debug.Print "  [(exiting sub): [(exiting sub): there is a syntax error in the path or the directory/folder doesn't exist, path: " & path & "]"
        picPath = 0: Exit Function 'return 0
    End If
End Function

   

]
 
Upvote 0
DanteAmor said:
You can do it as follows:
1. Select all the excel cells and lock the cells in Format Cells / Protection / Check Locked
View attachment 118279

2. Select the cells that you will be able to edit, for example E5 to G5 and remove the lock (Format Cells / Protection / UnCheck Locked)

3. Protect the sheet, but uncheck the "Select locked cells" option and press OK
View attachment 118280

Note: The code with the intersect is no longer necessary.

---------

Which code are you referring to?

If you have other code that works on the sheet, then at the beginning of the code you unprotect the sheet and at the end of the code you protect the sheet again, example:

VBA Code: 
Sub MacroTest()
  ActiveSheet.Unprotect "abc"
 
  'here your code
 
  ActiveSheet.Protect "abc"
  ActiveSheet.EnableSelection = xlUnlockedCells
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --
Click to expand...
I Added my full code can you check please
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
How to fix vba delay in runing the date rule
Replies
3
Views
87
Skyybot
Skyybot
R
  • Solved
A Cell doesn't show the date formatting as set in VBA
Replies
3
Views
150
Alex Blakenburg
A
O
  • Solved
VBA - floating photo
Replies
3
Views
341
RoryA
RoryA
D
  • Solved
Using VBA to determine Max Values when multiple worksheets are involved
Replies
4
Views
207
Fluff
Fluff
R
  • Question Question
Repeat VBA code to run but for another cell
Replies
0
Views
244
Ramadan
R

Forum statistics

Threads
1,223,884
Messages
6,175,177
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top