VBA Picture insert from directoy in merged cell and scaling

**heinzpol** · 02-13-2020, 11:12 AM

I have a worksheet with a few cells merged together (cells F12:H14). In these merged cells I want to automatically load a picture based on cell value in cell "I13".

Location of pictures:
The pictures are *.jpg files within the folder "pictures" which is in the same folder as the excel file. So the path must be relative.

Loading:
The picture must be loaded automatically when the worksheet is opened.

Sizing:
The picture must be autmatically sized to the size of the merged cells (F12:H14) and as both horizontally and vertically centered.

Duplication:
The sheet with the picture insert will automatically be duplicated based on the number of rows in a "data" sheet. The multiplied sheets gets automatically renamed to the cell values of the rows in de "data" sheet. So I guess that has someting to do with naming or placement of the VBA code?

I cannot find any VBA that fullfills my needs (as ever

). Can someone help me with this.

**PCI** · 02-13-2020, 06:39 PM

See how next code can help
To put in the sheet's code
The range where to put the picture has been named: MyPicture
See file attached

Option Explicit
Private Sub Worksheet_Activate()
Dim WkPath As String
WkPath = ActiveWorkbook.Path & "\" & "Pictures"
 
Dim PicRg  As Range
    Set PicRg = Range("MyPicture")
Dim WkPicN As String
WkPicN = Range("I13")
Dim WkPic As Picture

Dim WkRg As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each WkPic In .Pictures
            Set WkRg = .Range(WkPic.TopLeftCell.Address & ":" & WkPic.BottomRightCell.Address)
            If Not Intersect(WkRg, PicRg) Is Nothing Then WkPic.Delete
        Next
    End With

    
    Set WkPic = ActiveSheet.Pictures.Insert(WkPath & "\" & WkPicN & ".jpg")
'   Resize picture
    With WkPic
        .ShapeRange.LockAspectRatio = msoFalse
        .Top = PicRg.Top
        .Left = PicRg.Left
        .Width = (PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width)
        .Height = (PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height)
    End With
    Application.ScreenUpdating = True
End Sub

**heinzpol** · 02-14-2020, 03:46 AM

Thanks PCI!

That helps a lot. I tested it and 3 things which doesn't fullfill my needs:

1. Sizing of the pictures: the pictures are streched out to the whole size of the cellrange (MyPicture). The picture scaling must be set to "aspect ratio". Max. size of the picture must be appr. 95% of the height of cellrange ("MyPicture);

2. Location of the picture must be centered in "Mypicture";

3. The picture must be loaded/updated automatically when the cell value I13 changes. Now the picture changes after switching the worksheet.

I added some sample pictures to the example.

**PCI** · 02-14-2020, 05:25 AM

A remake
in a module put

Option Explicit

Sub Treat()
Dim WkPath As String
WkPath = ActiveWorkbook.Path & "\" & "Pictures"
 
Dim PicRg  As Range
    Set PicRg = Range("MyPicture")
Dim WkPicN As String
WkPicN = Range("I13")
Dim WkPic As Picture
Dim H, W

Dim WkRg As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each WkPic In .Pictures
            Set WkRg = .Range(WkPic.TopLeftCell.Address & ":" & WkPic.BottomRightCell.Address)
            If Not Intersect(WkRg, PicRg) Is Nothing Then WkPic.Delete
        Next
    End With

    
    Set WkPic = ActiveSheet.Pictures.Insert(WkPath & "\" & WkPicN & ".jpg")
'   Resize picture
    With WkPic
        .ShapeRange.LockAspectRatio = msoTrue
         W = PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width
         H = PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height
        .Height = 0.95 * H
        .Left = PicRg.Left + (W - .Width) / 2
        .Top = PicRg.Top + (H - .Height) / 2
        
 '       .Width = (PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width)
 '       .Height = (PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height)
    End With
    Application.ScreenUpdating = True

End Sub

in the sheet's code put

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If (Target.Address <> Range("I13").Address) Then Exit Sub
    Call Treat
End Sub

**heinzpol** · 02-14-2020, 06:58 AM

Thanks PCI! The example works fine, but with implementing in my workbook there are some difficulties:

In I13 I placed a Vlookup formula which gets the cellvalue from a worksheet "Data". Than the picture will not load.
See example.

And when no picture refenece is placed in column B from the sheet "Data" the picture must remain empty, with no fault messages.

Can I make a tweek or can you change the VBA code?

**PCI** · 02-14-2020, 07:10 AM

In I13 I placed a Vlookup

So you want to trigger the macro when calculation is done for I3 ??
There is an event linked to calculation but no reference to the cell updated.
A possibility could be to trigger when a selection is done ( what ever the cell) just to refresh the picture, is it OK ?

**heinzpol** · 02-14-2020, 07:49 AM

See attachment, this is how I exactly have it in my workbook.

- L13 automacically gets the name of the worksheet;
- K13 reads the value of L13 (a tweek because otherwise the Vloopup didn' t work in the sheet);
- I13 looks up the value of K13 in the sheet "Data" and gives back the value of column B in the sheet "Data"

The macro must be triggered by opening of the worksheet.

**PCI** · 02-14-2020, 08:00 AM

The macro must be triggered by opening of the worksheet.

For each sheet use

Option Explicit

Private Sub Worksheet_Activate()
    Call Treat
End Sub

**heinzpol** · 02-14-2020, 08:21 AM

Ok thank you, that did it!

One last thing: when no reference is made to a picture I get an error message (see pict). Can you put a line of code in the vba that when there is no value in I13 the macro stops.

Attachment 662750

**PCI** · 02-14-2020, 08:31 AM

Change

    Dim WkPicN As String
    WkPicN = Range("I13")

by

Dim WkPicN As String
    WkPicN = Range("I13")
    If (Len(WkPicN) = 0) Then exitSub

**heinzpol** · 02-14-2020, 08:37 AM

Thanks PCI! This works great!

**heinzpol** · 02-14-2020, 10:00 AM

1. Is it possible to add to the code that a message pops up when there is no corresponding picture in the folder.
2. Is it possible to delete the pictures in MyPicture when the macro starts. This will result in an empty MyPicture. Now the placed picture are not deleted when I13 is empty after an update

**PCI** · 02-14-2020, 10:07 AM

See next code


Option Explicit

Sub Treat()
Dim WkPath As String
WkPath = ActiveWorkbook.Path & "\" & "Pictures"
 
Dim PicRg  As Range
    Set PicRg = Range("MyPicture")
Dim WkPicN As String
    WkPicN = Range("I13")

Dim WkPic As Picture
Dim H, W

Dim WkRg As Range

    With ActiveSheet
        For Each WkPic In .Pictures
            Set WkRg = .Range(WkPic.TopLeftCell.Address & ":" & WkPic.BottomRightCell.Address)
            If Not Intersect(WkRg, PicRg) Is Nothing Then WkPic.Delete
        Next
    End With
    If (Len(WkPicN) = 0) Then Exit Sub
    
    Application.ScreenUpdating = False
    Set WkPic = ActiveSheet.Pictures.Insert(WkPath & "\" & WkPicN & ".jpg")
'   Resize picture
    With WkPic
        .ShapeRange.LockAspectRatio = msoTrue
         W = PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width
         H = PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height
        .Height = 0.95 * H
        .Left = PicRg.Left + (W - .Width) / 2
        .Top = PicRg.Top + (H - .Height) / 2
    End With
    Application.ScreenUpdating = True

End Sub

**heinzpol** · 02-14-2020, 12:42 PM

Thnx again. Unfortunately the scaling part is nog working well with different type of photo’s. Sometimes to big, other times to small. Seems like for some pictures the width is maximised to the height of MyPictures frame.

**PCI** · 02-14-2020, 12:50 PM

Can you send a phto where there is issue ?

**heinzpol** · 02-14-2020, 01:17 PM

Here two examples in my workbook with pictures original:

Attachment 662802
Attachment 662803

**PCI** · 02-14-2020, 02:27 PM

Links for attachments does not work
You could try also

Option Explicit

Sub Treat()
Dim WkPath As String
WkPath = ActiveWorkbook.Path & "\" & "Pictures"
 
Dim PicRg  As Range
    Set PicRg = Range("MyPicture")
Dim WkPicN As String
    WkPicN = Range("I13")

Dim WkPic As Picture
Dim H, W

Dim WkRg As Range

    With ActiveSheet
        For Each WkPic In .Pictures
            Set WkRg = .Range(WkPic.TopLeftCell.Address & ":" & WkPic.BottomRightCell.Address)
            If Not Intersect(WkRg, PicRg) Is Nothing Then WkPic.Delete
        Next
    End With
    If (Len(WkPicN) = 0) Then Exit Sub
    
    Application.ScreenUpdating = False
    Set WkPic = ActiveSheet.Pictures.Insert(WkPath & "\" & WkPicN & ".jpg")
'   Resize picture
    With WkPic
        .ShapeRange.LockAspectRatio = msoTrue
         H = PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height
        .Height = 0.95 * H
        .Top = PicRg.Top + (H - .Height) / 2
         W = PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width
        .Left = PicRg.Left + (W - .Width) / 2
    End With
    Application.ScreenUpdating = True
End Sub

**heinzpol** · 02-15-2020, 04:32 AM

OK I figured out what it was: the pcitures are 5 or 6 mb and that is far too large. So I resized them and then it go's well with the original code!

Only thing that lasts is: when thre is no corresponding picture in the pictures folder that the code gives an error. Solution to that:

Can you add a line that says that the pictures is not found in the folder and that stops the macro.

This is the latest code:

Option Explicit

Sub Treat()
Dim WkPath As String
WkPath = ActiveWorkbook.Path & "\" & "Pictures"
 
Dim PicRg  As Range
    Set PicRg = Range("MyPicture")
Dim WkPicN As String
    WkPicN = Range("I13")
    If (Len(WkPicN) = 0) Then Exit Sub

Dim WkPic As Picture
Dim H, W

Dim WkRg As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each WkPic In .Pictures
            Set WkRg = .Range(WkPic.TopLeftCell.Address & ":" & WkPic.BottomRightCell.Address)
            If Not Intersect(WkRg, PicRg) Is Nothing Then WkPic.Delete
        Next
    End With

    
    Set WkPic = ActiveSheet.Pictures.Insert(WkPath & "\" & WkPicN & ".jpg")
'   Resize picture
    With WkPic
        .ShapeRange.LockAspectRatio = msoTrue
         W = PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width
         H = PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height
        .Height = 0.95 * H
        .Left = PicRg.Left + (W - .Width) / 2
        .Top = PicRg.Top + (H - .Height) / 2
        
 '       .Width = (PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width)
 '       .Height = (PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height)
    End With
    Application.ScreenUpdating = True

End Sub

**PCI** · 02-15-2020, 07:40 AM

See next code


Option Explicit

Sub Treat()
Dim WkPath As String
WkPath = ActiveWorkbook.Path & "\" & "Pictures"
 
Dim PicRg  As Range
    Set PicRg = Range("MyPicture")
Dim WkPicN As String
    WkPicN = Range("I13")
    If (Len(WkPicN) = 0) Then Exit Sub

Dim WkPic As Picture
Dim H, W

Dim WkRg As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each WkPic In .Pictures
            Set WkRg = .Range(WkPic.TopLeftCell.Address & ":" & WkPic.BottomRightCell.Address)
            If Not Intersect(WkRg, PicRg) Is Nothing Then WkPic.Delete
        Next
    End With

    On Error GoTo EndSub
    Set WkPic = ActiveSheet.Pictures.Insert(WkPath & "\" & WkPicN & ".jpg")
    On Error GoTo 0
    
'   Resize picture
    With WkPic
        .ShapeRange.LockAspectRatio = msoTrue
         W = PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width
         H = PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height
        .Height = 0.95 * H
        .Left = PicRg.Left + (W - .Width) / 2
        .Top = PicRg.Top + (H - .Height) / 2
    End With
    Application.ScreenUpdating = True
EndSub:
End Sub

**heinzpol** · 02-15-2020, 08:49 AM

Great! Many Thanks All working fine now!!

Added also a message box in fault:

Here's the code for the Module:

Option Explicit

Sub Treat()
Dim WkPath As String
WkPath = ActiveWorkbook.Path & "\" & "Pictures"
 
Dim PicRg  As Range
    Set PicRg = Range("MyPicture")
Dim WkPicN As String
    WkPicN = Range("J13")
    If (Len(WkPicN) = 0) Then Exit Sub

Dim WkPic As Picture
Dim H, W

Dim WkRg As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each WkPic In .Pictures
            Set WkRg = .Range(WkPic.TopLeftCell.Address & ":" & WkPic.BottomRightCell.Address)
            If Not Intersect(WkRg, PicRg) Is Nothing Then WkPic.Delete
        Next
    End With

    On Error GoTo Errorhandler
    Set WkPic = ActiveSheet.Pictures.Insert(WkPath & "\" & WkPicN & ".jpg")
        
'   Resize picture
    With WkPic
        .ShapeRange.LockAspectRatio = msoTrue
         W = PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width
         H = PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height
        .Height = 0.95 * H
        .Left = PicRg.Left + (W - .Width) / 2
        .Top = PicRg.Top + (H - .Height) / 2
    End With
    Application.ScreenUpdating = True

Exit Sub
Errorhandler:
    MsgBox "There is no corresponding picture in the 'Pictures' folder!"
Exit Sub

EndSub:
End Sub

And here's the code for the sheet with the picture:

Private Sub Worksheet_Activate()
    Call Treat
End Sub

**PCI** · 02-15-2020, 09:48 AM

Yes, you customise the code, super.

**Zappatustra** · 10-20-2022, 03:43 AM

Dear all! Thanks for your effort. I would like to follow up this topic and need your support. I would need some slightly changes in the coding. I use an excel sheet where I want to insert and embed a Picture in a fixed area of merged cells with a fixed hight. My current code only insert a link to the picture that will not work when the source folder of the pictures changes. The picture size only need a fixed hight. The width according to aspect ratio. The default directory can be a general one and does not need to be fixed in the code. But it would be great if it opens the last used file path when I already used it in the current session.

Kindly ask for your support again! Thanks!

**PCI** · 10-20-2022, 04:53 AM

Hello Zappatustra,
As your need is different to the previous one in the thread it will be more effective to open your own thread and make reference to this one.
Always keep in mind to attach an Excel file to be able to fit completely to yours specifs.
PCI

Hybrid View

VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Re: VBA Picture insert from directoy in merged cell and scaling

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Hyperlink cell values to pdf file in a directoy

[SOLVED] Insert Picture in cell, click commanbutton to rename picture, lock cell and remove button

[SOLVED] import picture to fit in merged cell

[SOLVED] How do i insert a picture in merged cels, with autom. resizing ?

Bookmarks

Bookmarks

Posting Permissions