Directory w/ Pictures

[christianbiker]

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!

 

[pbornemeier]

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.

 

[CWatts]

Bill did a few podcasts that may help you. Here's one:

http://www.youtube.com/watch?v=rzUr44UXv9c

 

[christianbiker]

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]

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]

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