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]

1) The macro needs to be run when the sheet with the picture names is the current active sheet. (You're looking at it, open in front of you)
2) Always have the workbook saved somewhere in case things go bad. You can then exit without saving if needed.
3) Row 3, Row 29, Row 55 and so on should have picture names from column L To Column U. Need to be exact, no leading or trailing spaces.

The cells in the above mentioned Rows/Columns should have picture names incl extension like
"Nice Picture.jpg", "Wife and kids.jpg", "Last holiday in Peru.jpg". (Without the double quotation marks)

The path to where the pictures are is the 4th line in the code from Post #6. Don't forget the backslash (\) and double quotation marks.

 

[alekun86]

here is a wetransfer. thank you!

MTD RANKING .xlsx

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

 

[jolivanes]

I'll have a look later.
In the meantime, read the suggestions in the following sites.

Excel Tips: Why You Should Avoid Merging Cells

Use the Center Across Selection feature to easily merge cells in Excel.

edu.gcfglobal.org

Stop! Do Not Merge Cells in Excel - Heres why with fixes - The Excel Club

Find out why you should not merge cells in excel, the problems merged cells can cause and how you can overcome this problem.

theexcelclub.com

Don't merge cells in Excel // Best practices // PerfectXL Academy

It's very tempting to merge cells in Excel, but try to resist the temptation because merging cells can be dangerous!

www.perfectxl.com

 

[jolivanes]

Works perfect for me on your example providing you changed references as required (mentioned in Post #6)
All names for pictures to be imported need to be in a 26 row increase between rows (3, 29, 55, 81, 107, 133, 159, 185, 211, 237).
All top cells of the cells that will receive the picture need to be in a 26 row increase between rows as well as 13 rows down from picture names (16, 42, 68, 94, 130, 146, 172, 198, 224, 250).
The height of the receiving range for the pictures is 6 rows so bottom of range for pictures is 22, 48, 74, 100, 136, 152, 178, 204, 230, 256.
To test, I put the path to the folder where the pictures are in in Range("Y2") = Cells(2, 25) (C:\Users\My Name Here\Pictures)

Sub Maybe_So()
Dim path As String, i As Long, j As Long
Dim h As Double, w As Double, rat As Double
path = Cells(2, 25).Value & "\"    '<---- Path to the pictures
    For j = 3 To Cells(Rows.Count, 12).End(xlUp).Row Step 26    '<---- The 26 rows between rows with names as you mentioned
    For i = 12 To 15
    h = Cells(j, i).Offset(21).Top - Cells(j, i).Offset(13).Top    '<---- Height = bottom cell height - top cell height
    w = Columns(i).Width
        With ActiveSheet.Shapes.AddPicture(path & Cells(j, i).Value, False, True, Columns(i).Left, Cells(j, i).Offset(13).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(13).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