Picture Copy Help

[Emoncada]

I have the following code that works, but It only seems to allow 1 copy of the shape not multiple of the same.
Can anyone see what I need for it to allow multiple copies on sheet of same shape ?


Dim cell As Range
Dim shp49ers As Shape
Dim shpBears As Shape
Dim shpBengals As Shape

With ActiveSheet

Set shp49ers = .Shapes("49ers")
Set shpBears = .Shapes("Bears")
Set shpBengals = .Shapes("Bengals")

For Each cell In Range("B4:S22")

Select Case cell.Value

Case "49ers":
shp49ers.Copy
.Paste
.Shapes("49ers").Left = cell.Left
.Shapes("49ers").Top = cell.Top

Case "Bears":

shpBears.Copy
.Paste
.Shapes("Bears").Left = cell.Left
.Shapes("Bears").Top = cell.Top

Case "Bengals":
shpBengals.Copy
.Paste
.Shapes("Bengals").Left = cell.Left
.Shapes("Bengals").Top = cell.Top

End Select
Next cell
End With
End Sub

[patel]

did you try using .paste many times ?

[Emoncada]

Well i run this script and it should paste several pictures many times, based on the word that matches the shape.
So i can have 15 "Bears" in Column D so it should copy that shape ("Bears") to those cells

[mancubus]

try this:



Sub test()

Dim cll As Range
Dim shp49ers As Shape
Dim shpBears As Shape
Dim shpBengals As Shape

With ActiveSheet
Set shp49ers = .Shapes("shp49ers")
Set shpBears = .Shapes("shpBears")
Set shpBengals = .Shapes("shpBengals")
For Each cll In .Range("B4:S22")
Select Case cll.Value
Case "shp49ers"
shp49ers.Copy
.Paste
With Selection.ShapeRange.Item(1)
.Left = cll.Left
.Top = cll.Top
End With
Case "shpBears"
shpBears.Copy
.Paste
With Selection.ShapeRange.Item(1)
.Left = cll.Left
.Top = cll.Top
End With
Case "shpBengals"
shpBengals.Copy
.Paste
With Selection.ShapeRange.Item(1)
.Left = cll.Left
.Top = cll.Top
End With
End Select
Next cll
End With

End Sub

[Emoncada]

That worked Thanks mancubus

[mancubus]

you are welcome.

thanks for the feedback.