Msbox VBA code when cell value is changed

[Ramadan2512]

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

[/
 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

 

[DanteAmor]

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.

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.

 

[Ramadan2512]

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.

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.

Wow this was perfect thank you sooooo much I really do appreciate your effort and help it's working great thanks again

 

[Ramadan2512]

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

 

[Ramadan2512]

Wow this was perfect thank you sooooo much I really do appreciate your effort and help it's working great thanks again

 

[DanteAmor]

but now when one of them or both are empty, the cells "D44 and "J44" display the first image in my images folder

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.

 

[Ramadan2512]

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

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

 

[Ramadan2512]

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

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 ?

[/
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
]

 

[DanteAmor]

I did it - I just added your protect & unprotect parts to the old code and it's working good now

Well, that's what I said in post #2:

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:

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

do you have any suggestions to improve it ?

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

 

[Ramadan2512]

Well, that's what I said in post #2:

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.

great, thanks really for your help