Emoncada
11-08-2013, 12:11 PM
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
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