Help with adapting the range of a macro

[alekun86]

Hi!
I would like some help in order to change the range of action of a paste picture macro

I would like to paste photo in range:
- L17:U17 based on the value from L3:U3
- L40:U40 based on the value from L27:U27
- L63:U63 based on the value from L50:U50
- L86:U86 based on the value from L73:U73
- L109:U109 based on the value from L96:U96
- L132:U132 based on the value from L119:U119
- L155:U155 based on the value from L142:U142
- L178:U178 based on the value from L165:U165
- L203:U203 based on the value from L190:U190


here is the function:
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
Thank you

 

[jolivanes]

Can you explain in words in a concise manner what you want to happen.

 

[alekun86]

Thank you for the reply!
I would like pictures to being pasted from a folder based on a corrispondence bewteen pic name and name in cell.
The paste ranges will be variable, so i would like input all the ranges a need. for example:
- L17:U17 based on the name from L3:U3
- L40:U40 based on the value from L27:U27
ect

i posted a pic of the format.
Thank you

 

[jolivanes]

It looks like the cells where the word "image" is are Merge and Centered. Is that so?
No need to do that. Are the pictures heights the height from row 17 to 23 and the width of the column where the name is in?
From L3 to L17 = 14 rows, from L27 to L40 = 13 rows
From L3 to L27 = 24 rows and from L27 to L50 = 23 rows
From L178 to L203 = 25 rows
Any reason for these differences?
Makes your life a lot easier if you keep everything constant. Would need 2 more lines in following code if same distances.
This is for the 3rd row only. Is this a start?

Sub Start_Here()
Dim path As String, i As Long, j As Long
path = "C:\Whatever Folder Has Pictures Here\"
j = 3
    For i = 12 To 21
        ActiveSheet.Shapes.AddPicture(path & Cells(j, i).Value, False, True, Columns(i).Left, Cells(j, i).Offset(14).Top, _
        Columns(i).Width, Cells(j, i).Offset(21).Top - Cells(j, i).Offset(14).Top).Name = Cells(j, i).Value
    Next i
End Sub

Re: "change the range of action"
I do not know what that means so I could be totally off.

 

[alekun86]

Don`t mind the "change of action".

1) I will adapt the format to have the same number of rows (25)
2) About the pictures, I would like to keep original proportions but make their height fit inside row 17 to 23 and their width fit in the column where name is
3) 3 row is the start

thank you

 

[jolivanes]

Not tested!!!
Check offset values etc and change as required.

Sub Maybe_So()
Dim path As String, i As Long, j As Long
Dim h As Double, w As Double, rat As Double
path = "C:\Whatever Folder Has Pictures Here\"
    For j = 3 To Cells(Rows.Count, 12).End(xlUp).Row Step 25    '<---- The 25 rows between rows with names as you mentioned
    For i = 12 To 21
    h = Cells(j, i).Offset(21).Top - Cells(j, i).Offset(14).Top    '<---- Change the offset numbers if required
    w = Columns(i).Width
        With ActiveSheet.Shapes.AddPicture(path & Cells(j, i).Value, False, True, Columns(i).Left, Cells(j, i).Offset(14).Top, -1, -1)
            .Name = Cells(j, i).Value
            rat = .Height / .Width
            If rat < h / w Then
                .Left = Columns(i).Left
                .Width = w
                .Top = Cells(j, i).Offset(14).Top + (h - .Height) / 2
                    Else
                .Top = Cells(j, i).Offset(14).Top
                .Height = h
                .Left = Columns(i).Left + (w - .Width) / 2
            End If
        End With
    Next i
    Next j
End Sub

 

[alekun86]

I tried to run it but it says that the file cannot be found..

 

[jolivanes]

That should be an indication that the file does not exist. It can be several things of course.
It can be that the file is not in that folder (anymore), a spelling difference/mistake.
Does it bring in any pictures at all?
In a test file I have made, it all works as advertised.

 

[alekun86]

no no photos are brought it..
Sorry, I am not that used to VBA. I have some question:

1) should the file or the sheet have a specific name?
2) should the file be in the same folder of the photos or something like that?
2) the pic name should be in row 3, right? should it have the jpg extension or just the file name?

thank you

 

[jolivanes]

Upload your workbook to a free hosting site like dropbox and let us know the key to download it.