Macro for showing resizing pic based on cell

S

Solly123

New Member
Joined
Aug 1, 2018
Messages
5
Hi I am a novice on VBA.
But I wish to modify this formula below so that it can size the pics displayed proportionally.
The macro currently only show a pic based on cell value.
Pls help.
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPict As Picture
Dim PictureLoc As String

If Target.Address = Range("P3").Address Then

ActiveSheet.Pictures.Delete

PictureLoc = "C:\Users\TECHINICIAN\Desktop\LABELS" & Range("P3").Value & ".png"

With Range("U2")
Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)

End With

End If

End Sub



Regards
Solomon
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Sort by date Sort by votes
Solomon,

Welcome to the Board.

It's not exactly clear what you're trying to do, but the following might at least give you another approach...

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Shape
Dim PictureLoc As String

If Target.Address = Range("P3").Address Then
    ActiveSheet.Pictures.Delete
    PictureLoc = "C:\Users\TECHINICIAN\Desktop\LABELS" & Range("P3").Value & ".png"
    With Range("U2")
        'Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
        Set myPict = ActiveSheet.Shapes.AddPicture _
            (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
            Top:=.Top, Left:=.Left, Height:=.Height, Width:=.Width)
    End With
End If
End Sub

The code uses the Shapes.AddPicture method rather than the Pictures.Insert. This allows you to set the location (ie, Top and Left) as well as the dimensions (ie, Height and Width); these are currently set relative to Range("U2").

In the PictureLoc variable, there needs to be a backslash (\) between the path and file name. Don't know if it's present in Range("P3"). If not, the line should look like this...

Code: 
PictureLoc = "C:\Users\TECHINICIAN\Desktop\LABELS" & "\" & Range("P3").Value & ".png"

Cheers,

tonyyy
 
Upvote 0
Hi Tonyyy

Thanks !!!
It works fine I'm very happy.been frustrated for weeks.
Now I wanted it to do display other pics on same sheet. And the pic file on c: drive will be different but sometimes the same.
How do I proceed ?

Tx
Solly
 
Upvote 0
I used code below for example .
It works but the pic disappear when I input values in P3 and R3.
I want the pic to stay as long as there is value in P3 and or R3.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Shape
Dim PictureLoc As String

If Target.Address = Range("P3").Address Then
ActiveSheet.Pictures.Delete
PictureLoc = "C:\Users\buli\Desktop\pic" & Range("P3").Value & ".png"
With Range("z2")
'Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
Set myPict = ActiveSheet.Shapes.AddPicture _
(Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
Top:=.Top, Left:=.Left, Height:=100, Width:=80)

End With
End If

If Target.Address = Range("R3").Address Then
ActiveSheet.Pictures.Delete
PictureLoc = "C:\Users\buli\Desktop\label" & Range("R3").Value & ".png"
With Range("U20")
'Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
Set myPict = ActiveSheet.Shapes.AddPicture _
(Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
Top:=.Top, Left:=.Left, Height:=100, Width:=80)

End With
End If
End Sub
 
Upvote 0
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Shape
Dim PictureLoc As String

If Target.Address = Range("P3").Address Then
    For Each myPict In ActiveSheet.Shapes
        If myPict.Top = Range("Z2").Top And myPict.Left = Range("Z2").Left Then myPict.Delete
    Next myPict
    PictureLoc = "C:\Users\buli\Desktop\pic" & Range("P3").Value & ".png"
    With Range("z2")
        Set myPict = ActiveSheet.Shapes.AddPicture _
        (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
        Top:=.Top, Left:=.Left, Height:=100, Width:=80)
    End With
End If

If Target.Address = Range("R3").Address Then
    For Each myPict In ActiveSheet.Shapes
        If myPict.Top = Range("U20").Top And myPict.Left = Range("U20").Left Then myPict.Delete
    Next myPict
    PictureLoc = "C:\Users\buli\Desktop\label" & Range("R3").Value & ".png"
    With Range("U20")
        Set myPict = ActiveSheet.Shapes.AddPicture _
        (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
        Top:=.Top, Left:=.Left, Height:=100, Width:=80)
    End With
End If
End Sub
 
Upvote 0
Thank yu very much TONNY. This macro works perfectly and pics are firing the way they supposed to.

The only prob now is that the pics appear distorted some of them because they originally different sizes. So I want them to be a certain width but relative to the original pic size. Currently I'm defining a fixed width and height which is a prob.
 
Upvote 0
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Shape
Dim PictureLoc As String

If Target.Address = Range("P3").Address Then
    For Each myPict In ActiveSheet.Shapes
        If myPict.Top = Range("Z2").Top And myPict.Left = Range("Z2").Left Then myPict.Delete
    Next myPict
    PictureLoc = "C:\Users\buli\Desktop\pic" & Range("P3").Value & ".png"
    With Range("z2")
        Set myPict = ActiveSheet.Shapes.AddPicture _
        (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
        Top:=.Top, Left:=.Left, Height:=-1, Width:=-1)
        With myPict
            .LockAspectRatio = msoTrue
            .Width = 80 'Change as desired
        End With
    End With
End If

If Target.Address = Range("R3").Address Then
    For Each myPict In ActiveSheet.Shapes
        If myPict.Top = Range("U20").Top And myPict.Left = Range("U20").Left Then myPict.Delete
    Next myPict
    PictureLoc = "C:\Users\buli\Desktop\label" & Range("R3").Value & ".png"
    With Range("U20")
        Set myPict = ActiveSheet.Shapes.AddPicture _
        (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
        Top:=.Top, Left:=.Left, Height:=-1, Width:=-1)
        With myPict
            .LockAspectRatio = msoTrue
            .Width = 80 'Change as desired
        End With
    End With
End If
End Sub
 
Upvote 0
Hi again Tonny fixed ratio prob.( I have updated code below)
But I also realized it leaves the pics stacked on top of each other. Is there way to delete them?
I thought this code below will delete them but it seems not.

If myPict.Top = Range("F2").Top And myPict.Left = Range("F2").Left Then myPict.Delete

On the other hand do you have a separate macro for copy and paste value .
( Cell A1 has formula but want to paste its value to Cell B1) automatically.
because now the VBA that yu helped me with only fires on values only.
Tx
You got private email for private projects or is this only for public consultations?
=============================================

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Shape
Dim PictureLoc As String

If Target.Address = Range("E2").Address Then
For Each myPict In ActiveSheet.Shapes
If myPict.Top = Range("F2").Top And myPict.Left = Range("F2").Left Then myPict.Delete
Next myPict
PictureLoc = "C:\Users\TECHINICIAN\Desktop\MORITI BRANDS PTY\BEAUTY & WELLNESS\FACTORY\JOM PRICING MASTER\PRODUCTpic" & Range("E2").Value & ".png"
With Range("F2")
'Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
Set myPict = ActiveSheet.Shapes.AddPicture _
(Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
Top:=.Top, Left:=.Left, Height:=-1, Width:=-1)
With myPict
.LockAspectRatio = msoTrue
.Height = 60

End With
End With
End If

If Target.Address = Range("D29").Address Then
For Each myPict In ActiveSheet.Shapes
If myPict.Top = Range("F27").Top And myPict.Left = Range("F27").Left Then myPict.Delete
Next myPict
PictureLoc = "C:\Users\TECHINICIAN\Desktop\MORITI BRANDS PTY\BEAUTY & WELLNESS\FACTORY\JOM PRICING MASTER\COMPONENTRY" & "" & Range("D29").Value & ".jpg"

With Range("F27")
'Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
Set myPict = ActiveSheet.Shapes.AddPicture _
(Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
Top:=.Top, Left:=.Left, Height:=-1, Width:=-1)
With myPict
.LockAspectRatio = msoTrue
.Height = 80

End With
End If
 
Upvote 0
...it leaves the pics stacked on top of each other. Is there way to delete them?
Click to expand...

The following should take care of the "stacked" pics.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Shape
Dim PictureLoc As String

If Target.Address = Range("P3").Address Then
    For Each myPict In ActiveSheet.Shapes
        If Abs(myPict.Top - Range("Z2").Top <= 1) And Abs(myPict.Left - Range("Z2").Left) <= 1 Then myPict.Delete
    Next myPict
    PictureLoc = "C:\Users\buli\Desktop\pic" & Range("P3").Value & ".png"
    With Range("z2")
        Set myPict = ActiveSheet.Shapes.AddPicture _
        (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
            Top:=.Top, Left:=.Left, Height:=-1, Width:=-1)
        With myPict
            .LockAspectRatio = msoTrue
            .Height = 60 'Change as desired
        End With
    End With
End If

If Target.Address = Range("R3").Address Then
    For Each myPict In ActiveSheet.Shapes
        If Abs(myPict.Top - Range("U20").Top) <= 1 And Abs(myPict.Left - Range("U20").Left) <= 1 Then myPict.Delete
    Next myPict
    PictureLoc = "C:\Users\buli\Desktop\label" & Range("R3").Value & ".png"
    With Range("U20")
        Set myPict = ActiveSheet.Shapes.AddPicture _
        (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
        Top:=.Top, Left:=.Left, Height:=-1, Width:=-1)
        With myPict
            .Height = 80 'Change as desired
            .LockAspectRatio = msoTrue
        End With
    End With
    Set myPict = Nothing
End If
End Sub

On the other hand do you have a separate macro for copy and paste value .
( Cell A1 has formula but want to paste its value to Cell B1) automatically.
because now the VBA that yu helped me with only fires on values only.
Click to expand...

There are at least two approaches to address this. First, and preferred, is to use the input range(s) to the formula in A1 as the Target range(s) to trigger the code. Second, re-write the code as a Worksheet_Calculate event.

You got private email for private projects or is this only for public consultations?
Click to expand...

While this Forum does support private messaging, Forum Rules require requests for assistance remain public.

In future, please see my signature line on How to post your vba code.
 
Last edited:
Upvote 0
tonyyy said:
The following should take care of the "stacked" pics.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Shape
Dim PictureLoc As String

If Target.Address = Range("P3").Address Then
    For Each myPict In ActiveSheet.Shapes
        If Abs(myPict.Top - Range("Z2").Top <= 1) And Abs(myPict.Left - Range("Z2").Left) <= 1 Then myPict.Delete
    Next myPict
    PictureLoc = "C:\Users\buli\Desktop\pic" & Range("P3").Value & ".png"
    With Range("z2")
        Set myPict = ActiveSheet.Shapes.AddPicture _
        (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
            Top:=.Top, Left:=.Left, Height:=-1, Width:=-1)
        With myPict
            .LockAspectRatio = msoTrue
            .Height = 60 'Change as desired
        End With
    End With
End If

If Target.Address = Range("R3").Address Then
    For Each myPict In ActiveSheet.Shapes
        If Abs(myPict.Top - Range("U20").Top) <= 1 And Abs(myPict.Left - Range("U20").Left) <= 1 Then myPict.Delete
    Next myPict
    PictureLoc = "C:\Users\buli\Desktop\label" & Range("R3").Value & ".png"
    With Range("U20")
        Set myPict = ActiveSheet.Shapes.AddPicture _
        (Filename:=PictureLoc, linktofile:=msoFalse, savewithdocument:=msoTrue, _
        Top:=.Top, Left:=.Left, Height:=-1, Width:=-1)
        With myPict
            .Height = 80 'Change as desired
            .LockAspectRatio = msoTrue
        End With
    End With
    Set myPict = Nothing
End If
End Sub



There are at least two approaches to address this. First, and preferred, is to use the input range(s) to the formula in A1 as the Target range(s) to trigger the code. Second, re-write the code as a Worksheet_Calculate event.



While this Forum does support private messaging, Forum Rules require requests for assistance remain public.

In future, please see my signature line on How to post your vba code.
Click to expand...
I'm trying to pull the image location from another sheet in the same workbook so others can see the images when I give them the excel file. can this line be changed to point to another excel tab PictureLoc = "C:\Users\buli\Desktop\label" & Range("R3").Value & ".png"
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
How to insert jpg images into spreadsheet using VBA
2
Replies
12
Views
757
jolivanes
jolivanes
E
  • Question Question
insert picture by VBA
Replies
1
Views
474
rlv01
R
A
  • Question Question
Macro-inserted pictures are not showing on other computers
Replies
7
Views
316
rlv01
R
L
  • Solved
Excel VBA Picture insert but can't be shared with another computer
2
Replies
15
Views
3K
Logihk
L
I
  • Question Question
Image VBA for Multiple Rows and Columns
Replies
0
Views
497
Ivy_1011
I

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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