VBA (help with picture pasting formula)

[alekun86]

Hi Everybody,

Can I ask you help with the following VBA code?
It works fine. However when the formula find an empty cell it stops. I would like it to keep on going despite the empty cells here and there and stop when the are no more cells with text.

Thank you for you help



Sub Picture()
Dim pictname As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long, cPic

lastrow = Worksheets("sheet1").Range("B1").CurrentRegion.Rows.Count
x = 2
For x = 2 To lastrow
Set pastehere = Cells(x, 1)
pasterow = pastehere.Row
Cells(pasterow, 1).Select 'This is where picture will be inserted
pictname = Cells(x, 2) 'This is the picture name
Set cPic = ActiveSheet.Shapes.AddPicture("C:\Users\90009672\Desktop\baba\" & pictname & ".jpg", False, True, PosizLeft, PositTop, True, True)
' ActiveSheet.Pictures.Insert("C:\Users\90009672\Desktop\baba\" & pictname & ".jpg").Select 'Path to where pictures are stored
With cPic
.LockAspectRatio = msoFalse
.Height = 80#
.Width = 80#
.Left = Cells(pasterow, 1).Left + Cells(pasterow, 1).Width / 2 - .Width / 2
.Top = Cells(pasterow, 1).Top + Cells(pasterow, 1).Height / 2 - .Height / 2

End With
Next x
Set cPic = Nothing
End Sub

 

[alekun86]

I see!
now code starts working but stops at the empty cells with this message.
says the definition is not correct

 

[Siddharth Rout]

I see!
now code starts working but stops at the empty cells with this message.
says the definition is not correct

I believe the second button is "Debug" in Chinese? Click on that and tell me which line is it highlighting? And what is the exact error message

 

[alekun86]

the second button mean help and it send me here

Application-defined or object-defined error

Office VBA reference topic

learn.microsoft.com

by the way, if i put an image code in the blank cell the code works. it stops because the cell is empty

 

[Siddharth Rout]

Ah I understood. The error is because there is no image path in col B. You can handle it by adding an extra check If Len(Trim(.Cells(x, 2).Value2)) <> 0 Then as shown below.

Option Explicit

Sub InsertPicture()
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim x As Long
    Dim cPic As Shape
   
    '~~> Set this to the relevant worksheet
    '~~> Use Code Name if possible
    Set ws = ThisWorkbook.Sheets("Sheet1")
   
    With ws
        '~~> Find the last row. Fully qualify the Range and the Rows Object
        '~~> by adding a DOT before it
        LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
       
        '~~> Loop through the row. No need to select the cell where the paste
        '~~> is going to happen. You are handling that later
        For x = 2 To LastRow
            '~~> Check if the cell in B is not empty
            If Len(Trim(.Cells(x, 2).Value2)) <> 0 Then
                '~~> Insert the shape
                Set cPic = .Shapes.AddPicture("C:\Users\90009672\Desktop\baba\" & _
                                              .Cells(x, 2).Value2 & _
                                              ".jpg", False, True, 10, 10, 10, 10)
                                                         
                '~~> Customize the shape values
                With cPic
                    .LockAspectRatio = msoFalse
                   
                    .Height = 80
                    .Width = 80
                   
                    .Left = ws.Cells(x, 1).Left + ws.Cells(x, 1).Width / 2 - .Width / 2
                    .Top = ws.Cells(x, 1).Top + ws.Cells(x, 1).Height / 2 - .Height / 2
                End With
            End If
        Next x
    End With
End Sub

 

[alekun86]

works perfect!!!!!!
thank you so much Siddharth!!!

 

[Siddharth Rout]

Glad it's resolved. BTW, I would also recommend using proper error handling so that it can catch other errors. For example, what if the image path has a typo

 

[alekun86]

Dear Siddhart,

Sorry to bother you. The code works fine but the cell were the pic is pasted is now merged (the one were the pic name is not merged)
I would like the pic to be centered in the merged cell.

Thank you

 

[Siddharth Rout]

Try this (UNTESTED - Doing this from memory).

.Left = ws.Cells(x, 1).Left + (ws.Cells(x, 1).MergeArea.Width - .Width) / 2
.Top = ws.Cells(x, 1).Top + ws.Cells(x, 1).MergeArea.Height / 2 - .Height / 2

 

[alekun86]

perfect!
just another question..is there a way to paste the pictures so that when some cell are hidden the pics become also hidden?

thank you

 

[Siddharth Rout]

Check if the row is hidden and then hide the picture.

If ws.Cells(x, 1).EntireRow.Hidden Then