Adding a picture

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

Try this macro.

Code:

---

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

---

Thanks Jake that does the job lovely, is there an easy way to delete them again in one go?

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.

Code:

---

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.

Code:

---

WS.Shapes("Picture 4840").Copy

---

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

Try this.

Code:

---

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

---

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

Can you post an attachment?

Jake attached a file for u to look at, many thanks

Any Takers?

How about this.

Code:

---

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

---

That worked great jake consider this one solved with my thanks:friends:

You're Welcome :beerchug:

Take Care