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]

at which point of the code should I insert this command?
here is the code

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 = 3 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\FW23\" & _
.Cells(x, 2).Value2 & _
".jpg", False, True, 10, 10, 10, 10)

'~~> Customize the shape values
With cPic
.LockAspectRatio = msoFalse

.Height = 100
.Width = 100


.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


End With
End If
Next x
End With
End Sub

 

[Siddharth Rout]

I can give you the answer but, how about you tell me where would you insert the code?

I would recommend trying it and come back if you are still stuck?