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
 
Sort by date Sort by votes
Unlock all cells on the sheet
Lock only the range ("B7:N45").

I updated your code to protect and unprotect the sheet.
I also took the opportunity to reduce your code a little.

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.
  
  If Not Intersect(Target, Range("E5,G5"), Target) Is Nothing Then
    ws.Unprotect "abc"                      'unprotect at the beginning of the code
    
    For r = LBound(a) To UBound(a)
      If Target.Address(0, 0) = a(r, 2) Then
        ws.Range("D11").NumberFormat = "[$-,200]yyyy\/m\/d;@"
        ws.Range("D11").Value = ThisWorkbook.BuiltinDocumentProperties("Last Save time")
        On Error Resume Next: ws.Shapes(a(r, 1)).Delete: On Error GoTo 0
        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
      End If
    Next
        
    ws.Protect "abc"                        'protect at the end of the code
    ws.EnableSelection = xlUnlockedCells
  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

Try and comment.

😇
 
Upvote 0
Solution

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
DanteAmor said:
Unlock all cells on the sheet
Lock only the range ("B7:N45").

I updated your code to protect and unprotect the sheet.
I also took the opportunity to reduce your code a little.

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.
 
  If Not Intersect(Target, Range("E5,G5"), Target) Is Nothing Then
    ws.Unprotect "abc"                      'unprotect at the beginning of the code
  
    For r = LBound(a) To UBound(a)
      If Target.Address(0, 0) = a(r, 2) Then
        ws.Range("D11").NumberFormat = "[$-,200]yyyy\/m\/d;@"
        ws.Range("D11").Value = ThisWorkbook.BuiltinDocumentProperties("Last Save time")
        On Error Resume Next: ws.Shapes(a(r, 1)).Delete: On Error GoTo 0
        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
      End If
    Next
      
    ws.Protect "abc"                        'protect at the end of the code
    ws.EnableSelection = xlUnlockedCells
  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

Try and comment.

😇
Click to expand...
Wow this was perfect thank you sooooo much I really do appreciate your effort and help it's working great thanks again
 
Upvote 1
Mr. DanteAmor - thanks again for your help but now I faced one issue with the code in the part of inserting image according to the cell value in ( "E5 & G5")
what i was having is when E5 & or G5 is empty then there is no images appear in cell "D44 or J44"
but now when one of them or both are empty, the cells "D44 and "J44" display the first image in my images folder
please I need your help to fix it - if E5 in blank the no image to appear in D44 and also if g5 in blank no image in J44
 
Upvote 0
Ramadan2512 said:
but now when one of them or both are empty, the cells "D44 and "J44" display the first image in my images folder
Click to expand...
Check if it is an image that was previously loaded, delete all images manually and try the code again.

The macro deletes the image that is in the respective cell if you captured a value or if you deleted the value.

1729462186731.png
 
Upvote 0
DanteAmor said:
Check if it is an image that was previously loaded, delete all images manually and try the code again.

The macro deletes the image that is in the respective cell if you captured a value or if you deleted the value.

View attachment 118306
Click to expand...
Yes, I have tried that and deleted the image but once I put any number in E5 or G5 and remove it, the cells D44 & j44 go back to image number one in my source folder and dispaly it
Even when i removed the image No. 01 from my folder the cells started to dispaly image No. 02

for no bothering you, if it's complicated, can you please just replace the part of iimage inserting from my old code to your new modified one and resend it to me - I'm afraid to spoil it if i did it myself - thank you in advance
 
Upvote 0
Ramadan2512 said:
Yes, I have tried that and deleted the image but once I put any number in E5 or G5 and remove it, the cells D44 & j44 go back to image number one in my source folder and dispaly it
Even when i removed the image No. 01 from my folder the cells started to dispaly image No. 02

for no bothering you, if it's complicated, can you please just replace the part of iimage inserting from my old code to your new modified one and resend it to me - I'm afraid to spoil it if i did it myself - thank you in advance
Click to expand...
I did it - I just added your protect & unprotect parts to the old code and it's working good now do you have any suggestions to improve it ?


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.

    If Not Intersect(Target, Range("E5,G5"), Target) Is Nothing Then
       ws.Unprotect "abc"                      'unprotect at the beginning of the code

    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").Value = Format(ThisWorkbook.BuiltinDocumentProperties("Last Save time"), "short date")
            ws.Range("D11").NumberFormat = "yy/mm/dd"
            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
    ws.Protect "abc"                        'protect at the end of the code
    ws.EnableSelection = xlUnlockedCells
  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
Ramadan2512 said:
I did it - I just added your protect & unprotect parts to the old code and it's working good now
Click to expand...

Well, that's what I said in post #2:
DanteAmor said:
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:
Click to expand...
VBA Code: 
Sub MacroTest()
  ActiveSheet.Unprotect "abc"
  
  'here your code
  
  ActiveSheet.Protect "abc"
  ActiveSheet.EnableSelection = xlUnlockedCells
End Sub

Ramadan2512 said:
do you have any suggestions to improve it ?
Click to expand...
If it already works for you, that's what's important.

🤗
 
Upvote 0
DanteAmor said:
Well, that's what I said in post #2:

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


If it already works for you, that's what's important.

🤗
Click to expand...
great, thanks really for your help
 
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,175
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