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

 

[James006]

Hi,
Have you tried

lastrow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row

 

[alekun86]

Hi James,

Thank you for the reply. I tried just now but it doesn`t work (no pics are added)

 

[mehidy1437]

Try this

Sub Picture()
    Dim pictname As String
    Dim pastehere As Range
    Dim pasterow As Long
    Dim x As Long
    Dim lastrow As Long
    Dim cPic As Shape
    
    lastrow = Worksheets("Sheet1").Range("B1").CurrentRegion.Rows.Count
    
    For x = 2 To lastrow
        If Not IsEmpty(Cells(x, 4)) Then 'Check if cell in column D is not blank
            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)
            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
        End If
    Next x
    
    Set cPic = Nothing
End Sub

 

[alekun86]

Dear Mehidy,

Thank you for the reply. I tried but nothing happened.
Looking to the code column D is present: I don`t know if it`s related, but I would like the code to keep on working when there are some empty cells in column B where are also present the name of pictures.

Thank you in advance

 

[Siddharth Rout]

Few things that I would like to suggest.

1. Use Option Explicit at the top. This will force you to declare your objects/variables. I do not see PosizLeft and PositTop declared. Unless they are declared at Module/Global level.
2. Work with Objects and fully qualify your objects. Cells(pasterow, 1).Left will refer to the Activesheet and Activesheet may not be the one you think is active.
3. Avoid unnecessary use of Variables.
4. You may want to see the syntax of Shapes.AddPicture method (Excel)

Is this what you are trying? (Untested)

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
            '~~> 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
        Next x
    End With
End Sub

 

[alekun86]

Dear Sid,

I am a newbie so I do not understand coding that much. I tried to use your code but nothing happens.

 

[Siddharth Rout]

Dear Sid,

I am a newbie so I do not understand coding that much. I tried to use your code but nothing happens.

Ok I just tested the code and it works just fine. Couple of questions

1. Where did you paste the code and how are you running it?
2. What changes did you make to the above code?
3. Please explain what do you mean by "nothing happens". Any errors?
4. Possible to see the screenshot of your sheet1?

 

[alekun86]

Ok I just tested the code and it works just fine. Couple of questions

1. Where did you paste the code and how are you running it?
2. What changes did you make to the above code?
3. Please explain what do you mean by "nothing happens". Any errors?
4. Possible to see the screenshot of your sheet1?

1) I created a module and paste it inside and use the play button to run
2) I pasted it as it his
3) no error, no messages. the cell remains blank
4) I uploaded the screenshots

 

[Siddharth Rout]

The problem is that you pasted the code in a module of personal.xlsb and not in photo.xlsx.

The below line will not refer to the sheet in photo.xlsx. It will refer to the sheet in personal.xlsb.

Set ws = ThisWorkbook.Sheets("Sheet1")

In your case what happens if you change that line to

Set ws = ActiveWorkbook.Sheets("Sheet1")

or

Set ws = Workbooks("Photo.xlsx").Sheets("Sheet1")