Adding a picture

[gibbo1715]

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]

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]

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

[Jacob Hilderbrand]

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]

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]

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]

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]

Can you post an attachment?

[gibbo1715]

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

[gibbo1715]

Any Takers?

[Jacob Hilderbrand]

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]

That worked great jake consider this one solved with my thanks

[Jacob Hilderbrand]

You're Welcome

Take Care