Help with adapting the range of a macro

alekun86

New Member
Joined
Mar 28, 2023
Messages
19
Platform
  1. Windows
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
 
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.
 
Upvote 0

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
I'll have a look later.
In the meantime, read the suggestions in the following sites.

 
Upvote 0
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)
Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,253
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top