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

Popular posts from this blog