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

 

[Kenneth Hobson]

If you can make an example xls, it would be easier to help. You can post a free shared site like 4shared.com.

e.g. for Sheet2:
Name Picture Name
Bob Picture 1
Carol Picture 2
Ted Picture 3
Alice Picture 4

We could copy the image or move it to where you like based on the name on Sheet1.

One method is to just show the Picture for one name based on a data validation. Example date validation formula for the Sheet2 named range. =OFFSET(PicTable,,,,1)

Picture 1 is the name of the picture object on Sheet1. They are all hidden initially and the data validation cell makes the one selected visible in F1.

To use the code, right click sheet1's tab, View Code, and paste:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$A$2" Then Exit Sub
    Dim oPic As Picture
    Me.Pictures.Visible = False
    With Range("F1")
        For Each oPic In Me.Pictures
            If oPic.Name = .Text Then
                oPic.Visible = True
                oPic.Top = .Top
                oPic.Left = .Left
                Exit For
            End If
        Next oPic
    End With
End Sub

Notice that I set A2 on that sheet as the target. This is the cell that you put the data validation formula into.

 

[MickG]

Hi, If you name your Pictures (Pictures already in sheet) and name the cells to align them with, this code will position them one cell to the right.
You will need to play with the Height and Scale properties in the code to get a good result.

Sub SetPic()
Dim Rng As Range, Dn As Range, Pic As Shape
Set Rng = ActiveSheet.UsedRange

For Each Pic In ActiveSheet.Shapes
        For Each Dn In Rng
            If Dn.Value = Pic.Name Then
                ActiveSheet.Shapes(Dn.Value).Top = Dn.Top '.Address
                    ActiveSheet.Shapes(Dn.Value).Left = Dn.Offset(, 1).Left
                     ActiveSheet.Shapes(Dn.Value).Height = 40
                       ' ActiveSheet.Shapes(Dn.Value).Width = 50
                        ActiveSheet.Shapes(Dn.Value).ScaleWidth 0.85, msoScaleFromTopLeft
              End If
        Next Dn
Next Pic
End Sub

Regards Mick

 

[djl0525]

I'm not at my PC, but I'm so happy to hear from you both that I had to reply from my iPhone...

Do either of these solutions allow me to type the name in any order?

And I neglected to mention that I may need the name and picture to appear on the team sheet more than once. What is fixed is where I'll put the name and where I want the corresponding picture to appear (below the name). But Bob could appear in 3 places and so could Dave.

Your thoughts?

--DJ

 

[Kenneth Hobson]

Depends on how many Picture objects that you want to include. If you name your files in a consistent and unique manner, it might be a bit better for you. Embedding lots of pics could bloat your xls or corrupt it. Be sure to keep backup copies.

Methods:
1. Copy all the images to one sheet and then copy via code as needed from there.
2. Copy from a drive:\path location as needed via code.

 

[djl0525]

Thanks Kenneth! I got stuck on the range name and data validation parts. I know how to do both, I just couldn't put it together here.

Pretty cool, MickG! It worked! And it's real close to meeting my goal.

Can you make a few changes, please?

1. The source and the destination are different sheets. Sheet1 is the source and another sheet is the destination. And since I have so many destination sheets, I'd like to put the sheet name in an Input Box so I don't have to edit the code.
2. I need multiple copies of a given picture on the destination sheet. Currently, the code only displays the pic next to the last matching name. (I stepped through the code and watched it essentially move the pictures around.) Can you make it put the picture next to each matching name?
3. I don't know if it's already doing this, but I'd like it to first delete all of the pics on the destination sheet, then paste the picture next to the matching name.

I am so excited about this! This is going to save me countless hours!

Thanks --DJ

 

[MickG]

Hi, Try this:-
This code is a little more complicated than the last, but does a few more things.
Assumptions:-
All the picture that you want to tranfer to the destination sheets are in you "Source sheet" (sheet1), and are sized to correct shape/size for the destination sheets.
The Destination sheets will have the Picture Names in various cells as per your Picture Placement requirement.
Run this code from the "Source sheet".
The code will bring up an "Input Box" for you to enter the destination sheet name.
On entering the destination "Sheet Name" and clicking OK, the code will Delete all Pictures in that sheet.
The code then loops through each picture name in the "Source" sheet. Each picture is then tested in the destination sheet, if its name is found a copy of that picture is then placed in the destination sheet.
The code Copies One copy of the correct picture for each cell that has a picture name in the destination sheet..

The code now Counts each individual picture and Numbers them in the destination sheet, and does the same for each cell with a picture name. This means that The first picture of "Joe Bloggs" and its coresponding Cell will be named, say "Jo Bloggs", But the second and subsequent Cells (If there are more than one) and the Picture will be renamed "Joe Bloggs/1" and so on. this is so the code can align each picture to a specific name.
The code finally aligns all the pictures with the correct cells ,one column to the right.
NB:- When you re-run the code the Names in the destination sheet are Renamed to there original Names i.e the Numbering is removed.

Sub PicPaste()
Dim Rng As Range, pic As Shape, cl As Range, n As Integer, Q
Dim Sht As String, ost As String, Nam, c As Integer
On Error Resume Next
Sht = Application.InputBox(prompt:="Please Insert Sheet Name ", Title:="Paste Pictures to Sheet", Type:=2)
Set Rng = Sheets(Sht).UsedRange

Application.ScreenUpdating = False
 
 For Each pic In Sheets(Sht).Shapes
    If pic.Type = 13 Then
        pic.Delete
    End If
Next pic
For Each pic In ActiveSheet.Shapes
    If pic.Type = 13 Then
        For Each cl In Sheets(Sht).UsedRange
            cl.Value = Split(cl.Value, "/")(0)
                If cl.Value = pic.Name Then
                    pic.Copy: Sheets(Sht).Paste
                End If
        Next cl
    End If
Next pic

With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
       For Each pic In Sheets(Sht).Shapes
            If pic.Type = 13 Then
        If Not .Exists(pic.Name) Then
            n = n + 1
            .Add pic.Name, Array(n, 0)
        Else
            Q = .Item(pic.Name)
            Q(1) = Q(1) + 1
            .Item(pic.Name) = Q
            pic.Name = pic.Name & "/" & Q(1)
        End If
            End If
Next pic

For Each Nam In .keys
    For Each cl In Sheets(Sht).UsedRange
        If cl.Value = Nam Then
            c = c + 1
            If c > 1 Then cl.Value = cl.Value & "/" & c - 1
                Sheets(Sht).Shapes(cl.Value).Top = cl.Top
                Sheets(Sht).Shapes(cl.Value).Left = cl.Offset(, 1).Left
            End If
    Next cl
        c = 0
Next Nam
End With

Application.ScreenUpdating = True

End Sub

Regards Mick

 

[djl0525]

Thanks! It sounds great! I can't wait to try it.

Happy Holiday!
--DJ

 

[djl0525]

Thanks MikeG. It works great! You're a life saver!

After I posted yesterday, I realized if I run the code from sheet2, I wouldn't need an input box. Is that doable?

I also realized that I have a few pics on Sheet2 that don't originate from Sheet1. Is there a way to not delete them? Like, only delete the pics that are named on Sheet1? Or I could give a special name to the pics I don't want deleted and the macro could skip when it deletes pics. If not, I'll name them and add them to sheet1 so they get copied back to sheet2.

Thanks again!
--DJ

 

[djl0525]

I also realized that I have a few pics on Sheet2 that don't originate from Sheet1. Is there a way to not delete them? Like, only delete the pics that are named on Sheet1? Or I could give a special name to the pics I don't want deleted and the macro could skip when it deletes pics. If not, I'll name them and add them to sheet1 so they get copied back to sheet2.

Nevermind, I came up with a workaround.

I would still like to run the macro from the destination sheet, if possible.

Also, I have formulas on the destination sheets and I have discovered that the macro converts formulas to values. Is there a way to leave the formulas in tact?

--DJ