Excel VBA: Insert Multipul Picture from Directory on Cell Value Change Without
Insert a Multipale picture from the directory on the change of a cell value using Excel VBA.
In this video tutorial when someone changes the value of cell B2, a picture is automatically inserted from a folder in the directory. The cell is also automatically resized to be the same as the picture.
Code Link : https://personalcomputer85.blogspot.c...
This macro can be placed in a sub procedure and does not need to run on the worksheet change event. It could also be used in a loop to insert multiple pictures from that directory.
Below is the code used in the video. This can be copied and adapted for your own needs.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Range("b3").Select Then
Dim myPict As Picture
Dim PictureLoc As String
If Target.Address = Range("b3").Address Then
ActiveSheet.Pictures.Delete
PictureLoc = "D:\\FLIPKART\PHOTO\" & Range("b3").Text & ".jpg"
With Range("b5")
On Error GoTo errormessage:
Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
myPict.Height = 300
myPict.Width = 200
myPict.Top = .Top
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
myPict.ShapeRange.LockAspectRatio = msoTrue
errormessage:
If Err.Number = 1004 Then
MsgBox "File does not Exist, Please first update photo with .jpg File"
End If
End With
ElseIf Range("c3").Select Then
Dim myPict1 As Picture
Dim PictureLoc1 As String
If Target.Address = Range("c3").Address Then
PictureLoc1 = "D:\\FLIPKART\PHOTO\" & Range("c3").Text & ".jpg"
With Range("c5")
On Error GoTo errormessage1:
Set myPict1 = ActiveSheet.Pictures.Insert(PictureLoc1)
myPict1.Height = 300
myPict1.Width = 200
myPict1.Top = .Top
myPict1.Left = .Left
myPict1.Placement = xlMoveAndSize
myPict1.ShapeRange.LockAspectRatio = msoTrue
errormessage1:
If Err.Number = 1004 Then
MsgBox "File does not Exist, Please first update photo with .jpg File"
End If
End With
ElseIf Range("d3").Select Then
Application.ScreenUpdating = False
Dim myPict2 As Picture
Dim PictureLoc2 As String
If Target.Address = Range("d3").Address Then
PictureLoc2 = "D:\\FLIPKART\PHOTO\" & Range("d3").Text & ".jpg"
With Range("d5")
On Error GoTo errormessage2:
Set myPict2 = ActiveSheet.Pictures.Insert(PictureLoc2)
myPict2.Height = 300
myPict2.Width = 200
myPict2.Top = .Top
myPict2.Left = .Left
myPict2.Placement = xlMoveAndSize
myPict2.ShapeRange.LockAspectRatio = msoTrue
errormessage2:
If Err.Number = 1004 Then
MsgBox "File does not Exist, Please first update photo with .jpg File"
End If
End With
End If
End If
End If
End If
Application.ScreenUpdating = True
End Sub