You have to subtract the size of the picture from the size of the cell and
shift the picture by 1/2 the difference. You dod this using the height and
width properties as shown below.
Sub add_pictures()
Const PictureHeight = 120
DefaultPicture = "C:\temp\MyPicture.jpg"
Application.ScreenUpdating = False
'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp
LastRow = Cells(Rows.Count, "D").End(xlUp).Row
Rows(5).RowHeight = PictureHeight
For Each cell In Range("B4:IV4")
If cell <> "" Then
cell.Offset(1, 0).ClearContents
PictureFound = Dir(cell.Value)
If PictureFound <> "" Then
Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
Else
Set pict = ActiveSheet.Pictures. _
Insert(DefaultPicture)
End If
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
PictWidth = pict.Width
CellWidth = Cells(9, cell.Column).Width
WidthBorder = CellWidth - PictWidth
pict.Left = Cells(9, cell.Column).Left + (WidthBorder / 2)
PictHeight = pict.Height
CellHeight = Cells(9, cell.Column).Height
HeightBorder = CellHeight - PictHeight
pict.Top = Cells(9, cell.Column).Top + (HeightBorder / 2)
End If 'new line
Next cell
Exit Sub 'new line
End Sub
It should of been
cells(9,cell.column) = "Picture not Available"
You can replace this line with a insert of a standard picture like yoiu did
in the other part of the code.
Sub add_pictures()
Const PictureHeight = 120
DefaultPicture = "C:\temp\MyPicture.jpg"
Application.ScreenUpdating = False
'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp
LastRow = Cells(Rows.Count, "D").End(xlUp).Row
Rows(5).RowHeight = PictureHeight
For Each cell In Range("B4:IV4")
If cell <> "" Then
cell.Offset(1, 0).ClearContents
PictureFound = Dir(cell.Value)
If PictureFound <> "" Then
Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
Else
Set pict = ActiveSheet.Pictures. _
Insert(DefaultPicture)
End If
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pict.Top = Cells(9, cell.Column).Top
pict.Left = Cells(9, cell.Column).Left
End If 'new line
Next cell
Exit Sub 'new line
End Sub
:
Picturesare not part of the worksheet cell structure but instead apicture
is an object tjat sits ontop of the worksheet. You can put a picture ontop
of a cell by using the Top and Left properties. Top and Left are pixel
locations on the screen and changes when you change the height of a row or
Width of a column. the pciture will not move when the Row height is changed
or the column width is changed so the picture will look like it moved when
height/width are adjusted.
Use DIR to find if a picture exists before you inset the picture on the
worksheet. The code below will work as long as the formaty (ie jpg) of the
picture is recognized on your PC. You have to adjust the widthof the
Columns on the worksheet to the right size before you add the picture.
Another choise is to add the picture and use the width porperty ofthe cell
and the width porperty of the picture to get the picture to appearlike they
are the same width as the column. You can either make the all the columns
the same width and scale the picture to fit the column width, or scale the
Columns width to fit the picture width.
Sub add_pictures()
Const PictureHeight = 120
Application.ScreenUpdating = False
'deletepictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp
LastRow = Cells(Rows.Count, "D").End(xlUp).Row
Rows(5).RowHeight = PictureHeight
For Each cell In Range("B4:IV4")
If cell <> "" Then
cell.Offset(1, 0).ClearContents
PictureFound = dir(cell.Value)
if PictureFound <> "" then
Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pict.Top = cells(9,cell.column).Top
pict.Left = cells(9,cell.column).Left
else
cell(1,0) = "Picture not Available"
End If
End If 'new line
Next cell
Exit Sub 'new line
End Sub
:
From
pict.Top = cell.Offset(1, 0).Top
pict.Left = cell.Offset(1, 0).Left
to
pict.Top = Range("B9").Top
pict.Left = Range("B9").Left
:
Hi I have a Marco that insertspicturesin excel, I need to make a few
changes but I am having difficulty.
This macro is looking into a cell that has the picture file location
and it is inserting the picture right below that cell. But what I need
to change is, I need to be able toinsertthe picture to different
cell (example: the cell that has the location on the file is"B4" and
I want toinsertthe picture in cell "B9")
Below is the macro that I use. I would greatly appreciatefor your
help, Thank You.
Sub add_pictures()
Const PictureHeight = 120
Application.ScreenUpdating = False
'deletepictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp
LastRow = Cells(Rows.Count, "D").End(xlUp).Row
Rows(5).RowHeight = PictureHeight
For Each cell In Range("B4:IV4")
If cell <> "" Then
cell.Offset(1, 0).ClearContents
On Error GoTo NoPict 'new line
Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
If cell.Offset(1, 0).Value <> "Picture not Available" Then
'new line
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pict.Top = cell.Offset(1, 0).Top
pict.Left = cell.Offset(1, 0).Left
End If
End If 'new line
Next cell
Exit Sub 'new line
NoPict: cell.Offset(1, 0).Value = "Picture not Available" 'new line
Resume Next 'new line
End Sub- Hide quoted text -
- Show quoted text -
Thanks, but I am still having some difficulty, I used you line and yes
the picture was inserted in the right Cell but it is not only one
picture, the picture address starts from "B4: AA4" and thepictures
should be inserted from "B9:AA9" and if a picture is not available it
shouldinsertthe text "Picture not Available" with the addition of
you text it insets all thepicturesin cell "B9" one on top of each
other. and the text "Picture not Available" gets inserted in cell
"B5"
I thank you in advance I hope you can help.- Hide quoted text -
- Show quoted text -
Hi,
Thanks It works but I had to change the [cell(1,0) = "Picture not
Available"] to [cell(7,1) = "Picture not Available"] in order for the
"Picture not Available" text be in the same ROW as the pictures,
questions is, IS THIS CORRECT?
also is it possible that if it can not find the picture instead of
inserting the text "Picture not Available" can it insert a default
Picture file example ["C:\My Pictures\Picture_not_Available.jpg"]
Thank you very much!- Hide quoted text -
- Show quoted text -
Hi,
Thank you very much.
Just one more question I forgot to ask, how can I center the picture,
right now it places the picture in the TOP LEFT corner, how can I
place it at Horizontal:Center, Vertical:Center.
Thanks.- Hide quoted text -
- Show quoted text -