Hyperlink to the rectangle shape

Question

Dear All,

I need a vba code which will automatically show the item image in cell A1 when I navigate from one row to another.

We have about 1,000+ images with 1,000+ rows, and it is not possible to paste all the images and hyperlink it everytime we generate report. There are pictures with different resolutions but need shrink it to a box.

I am not an expert in VBA coding. Anybody who can help?  

Please see attached image for a visual explanation.

Thanks in advance.

pankaj

Answer 1

Dear Zach, 

Many thanks, it worked as I had desired.

Before asking for your help I was able to get some code from the net and did fine tuning to the vba code so that excel will show the image of stock item in column A.

This is my experience:

I have excel file with 220,000 rows which needs to show the image (low quality 3kb) of an item at row A. The macro inserted about 80,000 images in 6 hours and then excel became super slow. After inserting the images and after applying normal filter of excel the images shown were incorrect and also the opening of excel file became very slow. If you want to test the file and investigate more about the limitation of excel then I can send you the file with the images. Its very challenging and your wish, if you want to go ahead with it. If this feature is fine tuned in excel many corporation will used the excel for inventory reports, registration data with the photographs etc. Eventually extending computing power of excel.

Thanking you and Microsoft community again for this help.

regards

pankaj

Answer 2

Dear Zach,

since you are using:

LockAspectRatio =True

you need

either the width or the height (not both)

otherwise: LockAspectRatio =False

try this

With .ShapeRange .LockAspectRatio = msoTrue

.Width = 75

' .Height = 100

End With

or

With .ShapeRange .LockAspectRatio = msoTrue

' .Width = 75

.Height = 100

End With

TasosK

Answer 3

Hi Pankaj,

Sorry for my delayed response.

Your question actually inspired an entry on my blog, you can check it out if you want here.

So just replace the code you have at the moment with this:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Cells(ActiveCell.Row, 1) = "" Then

Dim shape As Excel.shape

'Delete the previous image(s)

For Each shape In ActiveSheet.Shapes

shape.Delete

Next

'Insert the image located at the path selected

On Error Resume Next

With ActiveSheet.Pictures.Insert(Cells(ActiveCell.Row, 1).Value)

With .ShapeRange

.LockAspectRatio = msoTrue

.Width = 75

.Height = 100

End With

.Left = ActiveSheet.Cells(1, 1).Left

.Top = ActiveSheet.Cells(1, 1).Top

.Placement = 1

.PrintObject = True

End With

End If

End Sub

Now the error won't appear if you select multiple cells, and you can click on any cell in the row, it will display the image link from column A.

Regards,

Zach

Answer 4

Dear Zach,

I really appreciate for your quick reply. I was able to run the program and the program will really help me.

Whenever I select multiple rows or multiple cells anywhere in the sheet the program generates an error and enters into vba debug mode. Secondly when I change the row the image needs to be changed (let the full path of the image be in column A), the present code runs only when I am in column A.

As you know that I am not an expert in VBA coding, if you can help me to solve this small issue.

Thanks in advance to you and Microsoft community.

regards

pankaj

Answer 5

Hi Pankaj,

Right click on Sheet1, then click on View Code, this will take you to the VBA editor with the code for Sheet1, which should be empty.

Now copy and paste the following code into the code window:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Intersect(Target, Range("A:A")) Is Nothing And Not Target.Value = "" Then

Dim shape As Excel.shape

'Delete the previous image(s)

For Each shape In ActiveSheet.Shapes

shape.Delete

Next

'Insert the image located at the path selected

With ActiveSheet.Pictures.Insert(Target.Value)

With .ShapeRange

.LockAspectRatio = msoTrue

.Width = 75

.Height = 100

End With

.Left = ActiveSheet.Cells(1, 1).Left

.Top = ActiveSheet.Cells(1, 1).Top

.Placement = 1

.PrintObject = True

End With

End If

End Sub

Every time you select a different cell, this code will check if it is in column A, and if the cell contains a value. If so, it will delete the previous image, and insert the new one.

Regards,

Zach