John Steel
New Member
- Joined
- Feb 7, 2017
- Messages
- 12
Greetings everyone,
First off let me say that I have searched for a day on this site and others trying to find an solution to my problem. I'm trying to insert five pictures into excel by looking them up via five reference cells containing the pictures' names on the worksheet.
Some of the things I'd like to accomplish with the macro:
Here are my reference and target cells
<tbody>
</tbody>
My picture files are all .jpg and located at "C:\Users\jstee\Dropbox\Comp photos" The worksheet is called "Comp Sheets" Hopefully I've not omitted anything required in my explanation.
The code I've tried to adapt from is for just one picture at this time as I want to get that to work before adding the loop necessary to do the other four pictures - although this I'll need help with as well I imagine. Here's what I have so far. I haven't gotten it to import anything so my troubleshooting is still in its infancy.
Any help would be greatly appreciated.
Thank you
First off let me say that I have searched for a day on this site and others trying to find an solution to my problem. I'm trying to insert five pictures into excel by looking them up via five reference cells containing the pictures' names on the worksheet.
Some of the things I'd like to accomplish with the macro:
- The macro would delete any existing pictures in the target areas.
- The pictures would maintain their aspect ratio and resize to the exisiting row height and be centered in the target range (four cells wide)
- If one of the references for the picture name is blank - delete any existing picture and skip attempting to import anything for that item
Here are my reference and target cells
Reference Cell (Name of picture file) | Target Range for importing picture |
A1 | C3:F3 |
A40 | C42:F42 |
A79 | C81:F81 |
A118 | C120:F120 |
A157 | C159:F159 |
<tbody>
</tbody>
My picture files are all .jpg and located at "C:\Users\jstee\Dropbox\Comp photos" The worksheet is called "Comp Sheets" Hopefully I've not omitted anything required in my explanation.
The code I've tried to adapt from is for just one picture at this time as I want to get that to work before adding the loop necessary to do the other four pictures - although this I'll need help with as well I imagine. Here's what I have so far. I haven't gotten it to import anything so my troubleshooting is still in its infancy.
Sub Picture()
Dim picname As String
Range("C3:F3").Select 'This is where picture will be inserted
picname = Range("A1") 'This is the picture name
On Error Resume Next
'delete previous pic
ActiveSheet.Pictures("Comp Sheets").Delete
Err.Clear
Err.Number = 0
On Error GoTo 0
If (Dir("C:\Users\jstee\Dropbox\Comp photos" & picname & ".jpg") = vbNullString) Then Exit Sub
ActiveSheet.Pictures.Insert("C:\Users\jstee\Dropbox\Comp photos" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Name = "Comp Sheets"
.Left = Range("C3:F3").Left
.Top = Range("C3:F3").Top
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 95#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Intersect(Target, Range("A1")) Is Nothing) Then
Exit Sub
End If
Application.EnableEvents = False
Call Picture
Application.EnableEvents = True
End Sub
Dim picname As String
Range("C3:F3").Select 'This is where picture will be inserted
picname = Range("A1") 'This is the picture name
On Error Resume Next
'delete previous pic
ActiveSheet.Pictures("Comp Sheets").Delete
Err.Clear
Err.Number = 0
On Error GoTo 0
If (Dir("C:\Users\jstee\Dropbox\Comp photos" & picname & ".jpg") = vbNullString) Then Exit Sub
ActiveSheet.Pictures.Insert("C:\Users\jstee\Dropbox\Comp photos" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Name = "Comp Sheets"
.Left = Range("C3:F3").Left
.Top = Range("C3:F3").Top
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 95#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Intersect(Target, Range("A1")) Is Nothing) Then
Exit Sub
End If
Application.EnableEvents = False
Call Picture
Application.EnableEvents = True
End Sub
Any help would be greatly appreciated.
Thank you