Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Columns("A:A")) Is Nothing Then Exit Sub Dim myPict As Picture With Cells(Target.Row, "D") Set myPict = Cells(Target.Row, "D").Parent.Pictures.Insert("D:\images\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With End Sub
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
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
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
With Selection .Left = Cells(pictureRow, picturePasteColumn).Left .Top = Cells(pictureRow, picturePasteColumn).Top .ShapeRange.LockAspectRatio = msoTrue 'Point 1 .ShapeRange.Height = 10# .ShapeRange.Width = 130# .ShapeRange.Rotation = 0# .Placement = xlMoveAndSize 'Point 2 End With
Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("D5")) Is Nothing Then Exit Sub Dim myPict As Picture With Range("I7:J12") Set myPict = Range("I7:J12").Parent.Pictures.Insert("F:\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Dim myPict As Picture If Not Intersect(Target, Range("C11")) Is Nothing Then With Range("G3:L8") Set myPict = Range("G3:L8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With ElseIf Not Intersect(Target, Range("V2")) Is Nothing Then With Range("N3:Q8") Set myPict = Range("N3:Q8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With Else Exit Sub End If End Sub
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
DON'T MISS