Need to link image to cell

djl0525

Well-known Member
Joined
Dec 11, 2004
Messages
1,235
In Excel, I have a sheet for each team that I manage. Each sheet lists the team members and displays their picture below their names. Some people are on multiple teams/sheets.

I have a master list with everybody's name and picture that I copy and paste the pictures from when putting a team together. This has become a very tedious process.

Is there a way I can type the person's name on a team sheet and have their picture automatically appear below their name? I don't know if this can be done with some kind of lookup or if it will involve VB. I tried making the picture the background of an Autoshape or comment, but I could not figure out how to dynamically change the picture based on the name in a cell.

Anybody have any ideas or suggestions?

Thanks in advance for your consideration,
--DJ
 

djl0525

Well-known Member
Joined
Dec 11, 2004
Messages
1,235
If the formula thing is a hassle, don't worry about it. I can record a macro to put the formulas back and append it to your code.
 

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Hi, If your Formulas are changing to values, is that because the Formulas return the Picture Names, which I then add Index numbers to , or some other reason.
With regard to running the code from the destination sheet, Presumably that is because the destination sheet is the only sheet you need to insert pictures Into ??. If this is the case , am I right in presuming that sheet (1) is the sheet from which all the pictures are Copied, and this sheet is called "Sheet1" or is it called "Source".
Regard Mick
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Hi, Try this in your destination sheet. This code refers to sheet (1) for your Pictures, and should not effect any formula in the Destination sheet.
The code should also only Delete pictures in destination sheet if they are also in sheet (1).
Code:
Sub Destsht()
Dim Rng As Range, pic As Shape, cl As Range
Dim c As Integer, Dpic As Shape
On Error Resume Next
Application.ScreenUpdating = False

For Each pic In Sheets("sheet7").Shapes
    If pic.Type = 13 Then
   For Each Dpic In ActiveSheet.Shapes
          If pic.Name = Split(Dpic.Name, "/")(0) Then Dpic.Delete
        Next Dpic
   End If
   Next pic
 
 For Each pic In Sheets("sheet7").Shapes
    If pic.Type = 13 Then
   For Each cl In ActiveSheet.UsedRange
        If cl.Value = pic.Name Then
            c = c + 1
            pic.Copy: ActiveSheet.Paste
               ActiveSheet.Shapes(pic.Name).Name = cl.Value & "/" & c
                  ActiveSheet.Shapes(cl.Value & "/" & c).Top = cl.Top
                     ActiveSheet.Shapes(cl.Value & "/" & c).Left = cl.Offset(, 1).Left
        End If
    Next cl
     End If
Next pic
Application.ScreenUpdating = True

End Sub
NB:- The other code was a bit self indulgent !!
Regards Mick
 

djl0525

Well-known Member
Joined
Dec 11, 2004
Messages
1,235
I'm running the new code now. I'm about to abort it 'cause it's taking a long time. The other code took about a minute to run, but this one has been going for over 3 minutes and still going...

DJ
 

djl0525

Well-known Member
Joined
Dec 11, 2004
Messages
1,235

ADVERTISEMENT

Hmmm... I ran the new code on a smaller, simpler test file and all it seemed to do was copy the code into the active cell on the destination sheet. No error alerts.

I've never seen that before.

--DJ
 

djl0525

Well-known Member
Joined
Dec 11, 2004
Messages
1,235
Okay, I think I got it. I changed Sheet7 to Sheet1 in two places. So far, so good...

Going back to the larger file now...

--DJ
 

djl0525

Well-known Member
Joined
Dec 11, 2004
Messages
1,235

ADVERTISEMENT

It worked great. The formulas on the sheet were not effect. Other objects on the sheet were not effect. I adjusted the OFFSET and it looks beautiful.

I was going to ask for a counter in the status bar so I could know if it was working or hung up, but it's much faster now so I don't need it so much.

Question: Now that it's running from the active sheet, where is the best place to store the code so I don't have to copy it to each sheet? Or should I leave it the way it is?

For the record, here's the final code.

Sub CopyKeyboards()

'Written by MrExcel's MikeG dated 04/13/09
'Source: http://www.mrexcel.com/forum/showthread.php?p=1903725#post1903725

Dim Rng As Range, pic As Shape, cl As Range
Dim c As Integer, Dpic As Shape
On Error Resume Next
Application.ScreenUpdating = False

For Each pic In Sheets("sheet1").Shapes
If pic.Type = 13 Then
For Each Dpic In ActiveSheet.Shapes
If pic.Name = Split(Dpic.Name, "/")(0) Then Dpic.Delete
Next Dpic
End If
Next pic

For Each pic In Sheets("sheet1").Shapes
If pic.Type = 13 Then
For Each cl In ActiveSheet.UsedRange
If cl.Value = pic.Name Then
c = c + 1
pic.Copy: ActiveSheet.Paste
ActiveSheet.Shapes(pic.Name).Name = cl.Value & "/" & c
'ActiveSheet.Shapes(cl.Value & "/" & c).Top = cl.Top
ActiveSheet.Shapes(cl.Value & "/" & c).Top = cl.Offset(-0.5, 0).Top
ActiveSheet.Shapes(cl.Value & "/" & c).Left = cl.Offset(, 1).Left
End If
Next cl
End If
Next pic
Application.ScreenUpdating = True

End Sub
Thanks a bunch! -- DJ
 
Last edited:

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Hi, Sorry about the sheet7 bit, I forgot to alter your code.
To run the code from other sheets. From the sheet with the code, Right click the sheet tab, Select "View Code" , you should now be looking at the code, Copy the code, On the VB Window toolbar select "Insert", "Module", New window appears, Paste the entire code into this window.

You can now run this code from any sheet by Clicking "Alt + F8", Macro dialog box appears. Select Macro "DestSht" (Or you new sub name)and click "Run" from the Dialog Box menu, Or alternativley Place a Button on each sheet with the code.
Code:
Call DestSht '(Or your new sub name)
Regards Mick
 

djl0525

Well-known Member
Joined
Dec 11, 2004
Messages
1,235
I moved the code per your instructions and all is well. Thank you.

It doesn't happen all the time, but occasionally the pics paste smaller that the source pic. Sometimes they're so small, I can't even see them. Can you add a command to select only the pics that were pasted by the code and size them? Height = .55, Width = 1.33.

FYI: This code will make me a better piano player. The images aren't pictures of people on a team, they're pictures of keyboard chords. Your code places little chord images in my custom made sheet music to remind me of the notes in the chord. Kind of like tabs for guitarists. I'm slow at reading music notation, but I can sight read pictures any day!! :)

-- DJ
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Hi, This is my last bit of code modified.
Alter the Code to suit you and the "Height" and "Width" properties to give you what you want, NB:- The result are not always as you expect, so you will have to Play with it.
Hope it improves you Piano Playing !
Code:
Sub Destsht()
Dim Rng As Range, pic As Shape, cl As Range
Dim c As Integer, Dpic As Shape
On Error Resume Next
Application.ScreenUpdating = False

For Each pic In Sheets("sheet1").Shapes
    If pic.Type = 13 Then
   For Each Dpic In ActiveSheet.Shapes
          If pic.Name = Split(Dpic.Name, "/")(0) Then Dpic.Delete
        Next Dpic
   End If
   Next pic
 
 For Each pic In Sheets("sheet1").Shapes
    If pic.Type = 13 Then
   For Each cl In ActiveSheet.UsedRange
        If cl.Value = pic.Name Then
            c = c + 1
            pic.Copy: ActiveSheet.Paste
               ActiveSheet.Shapes(pic.Name).Name = cl.Value & "/" & c
                 With ActiveSheet.Shapes(cl.Value & "/" & c)
                    .Top = cl.Top
                    .Left = cl.Offset(, 1).Left
                    .Height = 25
                    .Width = 50
                End With
        End If
    Next cl
     End If
Next pic
Application.ScreenUpdating = True

End Sub
Regards Mick
 

Watch MrExcel Video

Forum statistics

Threads
1,127,121
Messages
5,622,861
Members
415,935
Latest member
kes1973

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
Top