[/
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").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
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]
