PDA

View Full Version : [SOLVED] Adding a picture



gibbo1715
02-05-2005, 12:41 PM
Another question for you.

Is it possible to add a picture at the top center of each cell that is not blank without removing its content.

I have the picture ActiveSheet.Shapes("Picture 4840").Select
Selection.Copy bit

but want to know how to add it to the cells, there are also a lot of blank cells all over the place and no two cells with content are next to each other.

Many Thanks

Jacob Hilderbrand
02-05-2005, 07:25 PM
Try this macro.


Option Explicit

Sub Macro1()
Dim Cel As Range
Dim WS As Worksheet
Dim ConstantRange As Range
Dim FormulaRange As Range
Dim Shp As Shape
Set WS = Sheets("Sheet1")
On Error Resume Next
Set ConstantRange = WS.UsedRange.SpecialCells(xlCellTypeConstants, 23)
Set FormulaRange = WS.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
On Error GoTo 0
If Not ConstantRange Is Nothing Then
For Each Cel In ConstantRange
WS.Shapes("Picture 4840").Copy
WS.Paste
Set Shp = WS.Shapes(WS.Shapes.Count)
Shp.Top = Cel.Top
Shp.Left = Cel.Left + Cel.Width / 2 - Shp.Width / 2
Next Cel
End If
If Not FormulaRange Is Nothing Then
For Each Cel In FormulaRange
WS.Shapes("Picture 4840").Copy
WS.Paste
Set Shp = WS.Shapes(WS.Shapes.Count)
Shp.Top = Cel.Top
Shp.Left = Cel.Left + Cel.Width / 2 - Shp.Width / 2
Next Cel
End If
Set ConstantRange = Nothing
Set FormulaRange = Nothing
Set WS = Nothing
Set Shp = Nothing
End Sub

gibbo1715
02-06-2005, 01:02 AM
Thanks Jake that does the job lovely, is there an easy way to delete them again in one go?

Jacob Hilderbrand
02-06-2005, 01:43 AM
What I would do is put the picture you want to copy on a hidden sheet so that it won't be deleted then run this macro.



Sub DelShapes()
Dim WS As Worksheet
Set WS = Sheets("Sheet1")
WS.Shapes.SelectAll
Selection.Delete
End Sub


Then change this line to reference the new sheet with the picture to copy.

WS.Shapes("Picture 4840").Copy

gibbo1715
02-06-2005, 01:53 AM
Sorry Jake id thought of that one, should have mentioned I have other objects on the page and only need to delete all Pictures not all shapes, is that possible

Jacob Hilderbrand
02-06-2005, 02:08 AM
Try this.


Option Explicit

Sub DelPics()
Dim i As Long
Dim WS As Worksheet
Set WS = Sheets("Sheet1")
For i = WS.Shapes.Count To 1 Step -1
If WS.Shapes(i).Name = "Picture 4840" Then
WS.Shapes(i).Delete
End If
Next i
End Sub

gibbo1715
02-06-2005, 02:17 AM
That didnt work for me Jake, It deletes just that one picture, i ve set it up now so my picture is being called from a hidden sheet, picture 1 which is far better as you suggested.

I did try reversing the code but as i expected it deleted every object on the sheet

Jacob Hilderbrand
02-06-2005, 02:19 AM
Can you post an attachment?

gibbo1715
02-06-2005, 10:02 AM
Jake attached a file for u to look at, many thanks

gibbo1715
02-08-2005, 08:20 AM
Any Takers?

Jacob Hilderbrand
02-08-2005, 09:35 AM
How about this.


Option Explicit

Sub Button4_Click()
Dim Cel As Range
Dim WS As Worksheet
Dim ConstantRange As Range
Dim FormulaRange As Range
Dim Shp As Shape
Dim Hidden As Worksheet
Set WS = Sheets("Chart")
Set Hidden = Sheets("Hidden")
On Error Resume Next
Set ConstantRange = WS.UsedRange.SpecialCells(xlCellTypeConstants, 23)
Set FormulaRange = WS.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
On Error GoTo 0
If Not ConstantRange Is Nothing Then
For Each Cel In ConstantRange
Hidden.Shapes("Picture 1").Copy
WS.Paste
Set Shp = WS.Shapes(WS.Shapes.Count)
Shp.Name = "EmpIcon: " & Shp.Name
Shp.Top = Cel.Top
Shp.Left = Cel.Left + Cel.Width / 2 - Shp.Width / 2
Next Cel
End If
If Not FormulaRange Is Nothing Then
For Each Cel In FormulaRange
Hidden.Shapes("Picture 1").Copy
WS.Paste
Set Shp = WS.Shapes(WS.Shapes.Count)
Shp.Name = "EmpIcon: " & Shp.Name
Shp.Top = Cel.Top
Shp.Left = Cel.Left + Cel.Width / 2 - Shp.Width / 2
Next Cel
End If
Set ConstantRange = Nothing
Set FormulaRange = Nothing
Set WS = Nothing
Set Shp = Nothing
End Sub

Sub DelPics()
Dim i As Long
Dim WS As Worksheet
Set WS = Sheets("Chart")
For i = WS.Shapes.Count To 1 Step -1
If Left(WS.Shapes(i).Name, 9) = "EmpIcon: " Then
WS.Shapes(i).Delete
End If
Next i
End Sub

gibbo1715
02-08-2005, 11:57 AM
That worked great jake consider this one solved with my thanks:friends:

Jacob Hilderbrand
02-08-2005, 04:23 PM
You're Welcome :beerchug:

Take Care