Pictures keep pasting over each other when vba code executes

Closed
ssincerely Posts 3 Registration date Sunday October 9, 2016 Status Member Last seen October 12, 2016 - Oct 12, 2016 at 11:04 AM
TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 - Oct 25, 2016 at 12:05 PM
Credits to TrowaD in this Forum I was able to use his VBA Code for what I wanted but it just need a touch more to make it complete....The code below paste pictures on pictures when I click the button to update thereby letting the workbook bloated.

1. I want the pictures to replace the existing ones although they'll still be the same just that it'll be only one exist in each cell.
2. Instead of left and top align, I'd like it to be center in each cell.
3. If I protect the sheet macro does not run, I'd like to protect the sheet and make the pictures insert in their respect cells which are also locked when the sheet is protected.

Existing Code is:

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


Thanks in advance.
Related:

1 response

TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 555
Oct 25, 2016 at 12:05 PM
Hi Ssincerely,

To remove all pictures use this code line:
ActiveSheet.Pictures.Delete


So start your code with this to prevent multiples.

Best regards,
Trowa

Monday, Tuesday and Thursday are usually the days I'll respond. Bear this in mind when awaiting a reply.
0