Need to link image to cell

[djl0525]

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]

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.

 

[MickG]

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]

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).

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]

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]

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]

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]

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

 

[MickG]

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.

Call DestSht '(Or your new sub name)

Regards Mick

 

[djl0525]

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]

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 !

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