Problem Deleting A Range of shapes

[stakar]

Hi!
I have a little problem with a part of a code.
At first i use the following code to copy paste a rectangle to a
range.
-------------------------------------------------------------------
Sub Test()

Dim Rng As Range
Dim c As Range
Dim ws As Worksheet
Set ws = Worksheets("Result")

Set Rng = ws.Range("A3:A" & ws.Range("B65536").End(xlUp).Row)
Application.ScreenUpdating = False
ws.Shapes("Rectangle 51").Copy
For Each c In Rng
c.Select
ws.Paste
Next c
ws.Range("A1").Select
Application.ScreenUpdating = True
End Sub
-------------------------------------------------------------------------------
So far so good
Then i want to delete the all rectangles except the "rectangle 51"
which is in the cell A2
I use the following code
---------------------------------------------------------------------------------
Sub ShapesInRangeDelete()

Dim sh As Shape
Dim ws As Worksheet
Set ws = Worksheets("Result")
Set Rng = ws.Range("A4:A" & ws.Range("B65536").End(xlUp).Row)

For Each sh In ws.Shapes
If Not Application.Intersect(sh.TopLeftCell, Rng) Is Nothing Then
sh.Delete
End If
Next sh
End Sub
-------------------------------------------------------------------------------
But when it goes to the line
--If Not Application.Intersect(sh.TopLeftCell, Rng) Is Nothing Then
it gives me an error 1004

Can someone give me an idea??

Thanks in advance
Stathis

 

[Jim Rech]

Your code ran fine for me. I can only guess that there is something odd
about the particular shape the code is dealing with at the break. You're
going to have to debug the problem. I might suggest trying to figure out
which shape "sh" is when the error occurs.

--
Jim Rech
Excel MVP

| Hi!
| I have a little problem with a part of a code.
| At first i use the following code to copy paste a rectangle to a
| range.
| -------------------------------------------------------------------
| Sub Test()
|
| Dim Rng As Range
| Dim c As Range
| Dim ws As Worksheet
| Set ws = Worksheets("Result")
|
| Set Rng = ws.Range("A3:A" & ws.Range("B65536").End(xlUp).Row)
| Application.ScreenUpdating = False
| ws.Shapes("Rectangle 51").Copy
| For Each c In Rng
| c.Select
| ws.Paste
| Next c
| ws.Range("A1").Select
| Application.ScreenUpdating = True
| End Sub
| -------------------------------------------------------------------------------
| So far so good
| Then i want to delete the all rectangles except the "rectangle 51"
| which is in the cell A2
| I use the following code
| ---------------------------------------------------------------------------------
| Sub ShapesInRangeDelete()
|
| Dim sh As Shape
| Dim ws As Worksheet
| Set ws = Worksheets("Result")
| Set Rng = ws.Range("A4:A" & ws.Range("B65536").End(xlUp).Row)
|
| For Each sh In ws.Shapes
| If Not Application.Intersect(sh.TopLeftCell, Rng) Is Nothing Then
| sh.Delete
| End If
| Next sh
| End Sub
| -------------------------------------------------------------------------------
| But when it goes to the line
| --If Not Application.Intersect(sh.TopLeftCell, Rng) Is Nothing Then
| it gives me an error 1004
|
| Can someone give me an idea??
|
| Thanks in advance
| Stathis
|
|
| ---
| Message posted
|

 

[Don Guillett]

try this simple macro

Sub ShapesCut()
For Each S In ActiveSheet.Shapes
if s.name<>"Rectangle 51" then S.Cut
Next
End Sub

 

[stakar]

Your code works perfect but there is problem!
Your code deletes every shape but because i have several shapes on th
sheet i want to delete only the range
Set Rng = ws.Range("A4:A" & ws.Range("B65536").End(xlUp).Row)
Is it possible??

Thanks in advance
Stathis

 

[Don Guillett]

As I recall, shapes are not part of the range, but of the sheet. So, you
would have to do it by the name or number of the shape. I thought you asked
to delete all but Rectange 51. This is what my code did.