Directory w/ Pictures

christianbiker

Active Member
Joined
Feb 3, 2006
Messages
365
Greetings all...

I am wondering if it is possible to have pictures sorted or displayed according to data in a specific cell. For instance if cell A1 = Bob, then cell A2 = picture of bob.

If this is possible, my next question is if it will follow that text around a spreadsheet?

As an example, if I add 3 more people and Bob is in A1 anymore, can I make his picture follow him to A5?

Any other suggestions or ideas would be entertained.

Thanks!
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,896
If you make the cell big enough to hold the picture then format the picture to Move and size with cell, then it will sort with the appropriate row. The row heights do not move with the data, so if the rows are different heights, the image may be compressed or expanded as it is sorted to different rows.
 

christianbiker

Active Member
Joined
Feb 3, 2006
Messages
365
Thanks for the replies...

CWatts, I think what I saw in the video may work but my question is how can I show the picture in the cell, not as a comment. Then the next question...is there a way that I can use this format for anywhere in the spreadsheet? Not necessarily in one column? For example if the pic name moved from A2 to F9 is there code that would work that when run would move the picture to that location as the file name will now be there?

Here is the code...not sure how to proceed.

Sub addpics()
For i = 2 To 7
PicName = "C:\Documents and Settings\Chad\My Documents\My Pictures\" & Cells(i, 1) & ".jpg"
With Cells(i, 1). ????
.Shape.Fill.UserPicture PicName
.Shape.Height = 200
.Shape.Width = 200
End With
Next i
End Sub

Thanks!
 

christianbiker

Active Member
Joined
Feb 3, 2006
Messages
365
Ok...I have been doing some work and found something that is working however over time I can see this becoming very labour intensive as people are added. Is there a way to set up the below code to check everything and insert the appropriate picturee without adding code for each cell?

Also, as these pictures will move around based on order (alphabetical)...can I set up a function that deletes all pictures prior to adjusting/adding the new one so there is no overlap of pics?

The size of the pictures is a constant and is done to the picture itself (200x200). I simply pre adjust the cell to fit the picture and whoala! My other question is, is there a way I can also set up the code to center each picture in it's own cell.

Thanks...see below:

Sub Macro1()

Range("A1").Select
If Range("A1") > "" Then
ActiveSheet.Pictures.Insert( _
"C:\Documents and Settings\Chad\My Documents\My Pictures\CBTC Directory\" & Range("A1") & ".jpg" _
).Select
End If

Range("C1").Select
If Range("C1") > "" Then
ActiveSheet.Pictures.Insert( _
"C:\Documents and Settings\Chad\My Documents\My Pictures\CBTC Directory\" & Range("C1") & ".jpg" _
).Select
End If

Range("E1").Select
If Range("E1") > "" Then
ActiveSheet.Pictures.Insert( _
"C:\Documents and Settings\Chad\My Documents\My Pictures\CBTC Directory\" & Range("E1") & ".jpg" _
).Select
End If

Range("A4").Select
If Range("A4") > "" Then
ActiveSheet.Pictures.Insert( _
"C:\Documents and Settings\Chad\My Documents\My Pictures\CBTC Directory\" & Range("A4") & ".jpg" _
).Select
End If

Range("C4").Select
If Range("C4") > "" Then
ActiveSheet.Pictures.Insert( _
"C:\Documents and Settings\Chad\My Documents\My Pictures\CBTC Directory\" & Range("C4") & ".jpg" _
).Select
End If

Range("E4").Select
If Range("E4") > "" Then
ActiveSheet.Pictures.Insert( _
"C:\Documents and Settings\Chad\My Documents\My Pictures\CBTC Directory\" & Range("E4") & ".jpg" _
).Select
End If

End Sub
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,896
Code:
Option Explicit

Sub DeleteAllPicturesFromActiveSheet()

    Dim lX As Long
    Dim lShapeCount As Long
    Dim iAnswer As Integer
    
    lShapeCount = ActiveSheet.Shapes.Count
    If lShapeCount > 1 Then
        iAnswer = MsgBox("Delete " & lShapeCount & " pictures from this worksheet?", vbOKCancel, "Delete Pictures")
        If iAnswer = vbOK Then
            For lX = lShapeCount To 1 Step -1
                ActiveSheet.Shapes(lX).Delete
            Next
        End If
    End If
    
End Sub

Sub AddPicturesInSpecifiedRange()

    Dim rngCheckRange As Range
    Dim rngCell As Range
    Dim lX As Long
    Dim sImageSourceDirectory As String
    
    Set rngCheckRange = Range("A1,C1,E1,A4,C4,E4") 'This could be a simple range instead ("A1:E4")
    sImageSourceDirectory = "C:\Documents and Settings\Chad\My Documents\My Pictures\CBTC Directory\"
    
    For Each rngCell In rngCheckRange
        If rngCell.Value > "" Then 'you could check for the right 4 characters being .jpg
            rngCell.Select
            ActiveSheet.Pictures.Insert(sImageSourceDirectory & rngCell.Value & ".jpg").Select
            If Selection.Width < rngCell.Width Then Selection.Left = rngCell.Left + (rngCell.Width - Selection.Width) / 2
            If Selection.Height < rngCell.Height Then Selection.Top = rngCell.Top + (rngCell.Height - Selection.Height) / 2
        End If
    Next

    Set rngCheckRange = Nothing
End Sub
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,651
Messages
5,838,576
Members
430,557
Latest member
MK15

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