Hi Sachin,
For that you will need to add some ElseIf's.
I added two of them in the code of Cakmak. Look for the green text to see the start and end of these ElseIf blocks, so you could add more if needed.
Here is the adjusted code:
Private Sub CommandButton1_Click()
Dim pictureNameColumn As String 'column where picture name is found
Dim picturePasteColumn As String 'column where picture is to be pasted
Dim pictureName As String 'picture name
Dim lastPictureRow As Long 'last row in use where picture names are
Dim pictureRow As Long 'current picture row to be processed
Dim pathForPicture As String 'path of pictures
pictureNameColumn = "A"
picturePasteColumn = "H"
pictureRow = 5 'starts from this row
'error handler
On Error GoTo Err_Handler
'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
'stop screen updates while macro is running
Application.ScreenUpdating = False
pathForPicture = "C:\images\"
'loop till last row
Do While (pictureRow <= lastPictureRow)
pictureName = Cells(pictureRow, "A") 'This is the picture name
'if picture name is not blank then
If (pictureName <> vbNullString) Then
'check if pic is present
'Start If block with .JPG
If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End If block with .JPG
'Start ElseIf block with .PNG
ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .PNG
'Start ElseIf block with .BMP
ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .BMP
Else
'picture name was there, but no such picture
Cells(pictureRow, picturePasteColumn) = "No Picture Found"
End If
Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop
Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub
End Sub
Best regards,
Trowa
I don't understand. When you make a change to either cell D5 or H5, that cells value will be used as picture name.
Best regards,
Trowa
i save my pictures in folder kelas 1 .... i try insert two photos but failed
example in cell c11 i type banana then banana.jpg come then i type apple to cell v2 then apple.jpg come .... two pictures take in one sheet ("lookupgambar").
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim InsertPict As Object
Dim bolo As Object
Dim NamaFile As String
If Not Intersect(Target, Range("$C$11")) Is Nothing Then
End If
NamaFile = ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg"
If Dir(NamaFile) = "" Then NamaFile = ThisWorkbook.Path & "\NoPhoto.jpg"
Call Hapus
Set InsertPict = ActiveSheet.Pictures.Insert(NamaFile)
With InsertPict
.Name = "SuperHero"
.Top = [G3].Top
.Left = [G3].Left
.Width = [G3:L8].Width
.Height = [G3:L8].Height
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Weight = 2.25
End With
If Intersect(Target, Range("$v$2")) Is Nothing Then Exit Sub
NamaFile = ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg"
If Dir(NamaFile) = "" Then NamaFile = ThisWorkbook.Path & "\NoPhoto.jpg"
Call Hapus1
Set bolo = ActiveSheet.Pictures.Insert(NamaFile)
With bolo
.Name = "Bandi"
.Top = [n3].Top
.Left = [n3].Left
.Width = [n3:q8].Width
.Height = [n3:q8].Height
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Weight = 2.25
End With
End Sub
Private Sub Hapus()
On Error Resume Next
ActiveSheet.Pictures("SuperHero").Delete
End Sub
Private Sub Hapus1()
On Error Resume Next
ActiveSheet.Pictures("Bandi").Delete
End Sub
Give the code below a try:
Best regards,
Trowa
very help... thanks again