Excel VBA: Insert Multipul Picture from Directory on Cell Value Change Without
Excel VBA: Insert Multipul Picture from Directory on Cell Value Change Without Error
Youtube Link : https://youtu.be/pqpVp01sWB0
Code : This Code paste in Active sheet
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
Comments
Post a Comment