Please help with my code

[Please Help]

Good morning,

Please help with my code below.

Basically, my code will remove the shapes in the cells selected (instead of
all the shapes in the active worksheet) of the active worksheet, and it is
not work.

For example, if I select cells A1, B1, and C5:G10 and when I run the macro,
the macro will only remove the shapes in those cells. Please note the cells
selected will be done by users and may not be the same as referenced above.

Thanks.

Dim cMarks As Shape
Dim sCells as Range
Dim cCount as Integer

sCells.Select
For Each sCells In ActiveSheet
For Each cMarks In sCells.Shapes
If cMarks.Type = 13 Then
cCount = cCount + 1
cMarks.Delete
End If
Next cMarks
Next sCells
MsgBox "You have removed " & cCount & " check marks in highlighted cells
'" & sCells.Name & "' of the Worksheet '" &
ActiveSheet.Name & "'."

 

[Carim]

Hi,

Below is my code to delete text boxes ...
You can adapt it to your situation :

Sub DeleteTextBox()
Dim myshape As Shape
Dim rng As Range
For Each myshape In ActiveSheet.Shapes
Set rng = myshape.TopLeftCell
If Intersect(rng, ActiveCell) Is Nothing Then
'do nothing
Else
myshape.Delete
End If
Next myshape
End Sub

HTH

 

[Don Guillett]

Please use a MEANINGFUL subject line. I'm not sure you can select the range
if the the shape is covering it, But if so adapt this to suit.

Sub ShapesInRangeDelete() 'Iain
Dim shpLoop As Shape
Set rngUsable = Range("e1:e24")
For Each shpLoop In ActiveSheet.Shapes
'does the top left corner of the shape overlap rngUsable?
If Not (Application.Intersect(rngUsable, shpLoop.TopLeftCell) Is Nothing)
Then
shpLoop.Delete
End If
Next shpLoop
End Sub
======
This might work best. Hold down the ctrl key while selecting the shapes(not
the range)

Sub DeleteSelectedshapes()
Selection.Delete
End sub

 

[Joel]

the problem is shapes do not sit in cell they sit ontop of cells. they also
don't have a row or column.

Both cells and shapes do have left, top, height, width which are pixel
measurments. You can write code like the sample below to compartre shapes
with cells.

Note: The code below doesn't test the right side or botttom of the shape to
see if it is inside the range. Wasn't sure if this is a requirement. The
code only tests the left side of the shape and the top of the shape.

 

[Please Help]

Hi Carim,

Thanks for the code. I take your code and make a few changes to suit my
needs, and it does not seem to work. Can you help me more? Below is my
modified code.

In addition to removing the shapes, I also like to include the code to
message the users the # of shapes got removed and referencing the cells
selected and worksheet.

In addition, how does your code know what type of shape to remove because I
only want to remove the shapes which are 13 (msoLinkedPicture).

Thanks.

Dim myshape As Shape
Dim rng As Range
dim cCount as Integer
For Each myshape In ActiveSheet.Shapes
Set rng = myshape.TopLeftCell
If Intersect(rng, ActiveCell) Is Nothing Then
Else
cCount = cCount + 1
myshape.Delete
End If
Next myshape
MsgBox "You just removed " & cCount & " check marks in highlighted cells
'" & rng.Name & "' of the Worksheet '" & ActiveSheet.Name & "'."

 

[Please Help]

Don,

First of all, thanks for the code. Secondly, I will make a note about the
meaningful subject line.

I take your code and make a few changes to suit my needs, and it does not
seem to work. Can you help me more? Below is my modified code.

In addition to removing the shapes, I also like to include the code to
message the users the # of shapes got removed and referencing the cells.

In addition, how does your code know what type of shape to delete because I
only want to delete the shapes which are 13 (msoLinkedPicture)? You also
reference the range E1:E24. Would it work if a user selects other than
E1:E24?

What do you mean by "'does the top left corner of the shape overlap
rngUsable?"?

Thanks.


Dim shpLoop As Shape
dim cCount as Integer
Set rngUsable = Range("e1:e24")
For Each shpLoop In ActiveSheet.Shapes
'does the top left corner of the shape overlap rngUsable?
If Not (Application.Intersect(rngUsable, shpLoop.TopLeftCell) Is Nothing)
Then
cCount = cCount + 1
shpLoop.Delete
End If
Next shpLoop
MsgBox "You just removed " & cCount & " check marks in highlighted cells
'" & rngUsuable.Name & "' of the Worksheet '" & ActiveSheet.Name & "'."

 

[Don Guillett]

Just use the 2nd code I provided after they hold the ctrl key and select
each shape

 

[Please Help]

Joel,

Thanks for your response. For what I need, I don't think we can use the
shape measurement because we use many different shapes. However, the shapes
are type 13 (msoLinkedPicture).

Anymore idea?

Thanks.

 

[Please Help]

Don,

Shapes will not be selected because there may be a lot of shapes that we
want to remove. If the shapes are to be selected individually, it will take
a long time.

I was hoping that I can just select (highlight) the cells where the shapes
are. Then the macro will remove all the shapes in those cells.

Plus, I do not want to remove all the shapes in the active sheet. For that,
I have a separate macro.

One question: By highlighting a group cells, wouldn't make those cells
active cells? Therefore, can we use the syntax "Activecell" in the code for
what I need?

Thanks again for your helps.

 

[Joel]

I forgot to post my code. All shapes have four location/size parameters
Top, Left, Height, Width

Sub test()

Dim cMarks As Shape
Dim sCells As Range
Dim cCount As Integer

RLeft = Range("A1").Left
RTop = Range("A1").Top
Rright = Range("E5").Left + Range("E5").Width
RBottom = Range("E5").Top + Range("E5").Width

For Each cMarks In sCells.Shapes
If cMarks.Type = 13 Then
If cMarks.Top >= RTop And _
cMarks.Top <= RBottom And _
cMarks.Left >= RLeft And _
cMarks.Left <= Rright Then

cCount = cCount + 1
cMarks.Delete
End If
End If
Next cMarks
MsgBox "You have removed " & cCount & " check marks in highlighted cells "
'" & sCells.Name & "' of the Worksheet '" & ActiveSheet.Name & "'."
End Sub

 

[Please Help]

Joel,

Thanks for the code. When I run your code, I got the following error:

Run-time error '91': Object variable or With block variable not set

And it pointed me to the line "For Each cMarks In sCells.Shapes".

I am just curious something. How does the code know the range for "sCells"
because there is no reference for range for sCells?

Thanks.

 

[Joel]

from
For Each cMarks In sCells.Shapes
to
For Each cMarks In ActiveSheet.Shapes

 

[Please Help]

Joel,

Thanks for your patience and your continuing help.

I changed the code to ActiveSheet as you indicated below, and I am still
getting the same error message.

However, this time it pointed me to the MsgBox:

MsgBox "You have removed " & cCount & " check marks in highlighted cells "
'" & sCells.Name & "' of the Worksheet '" & ActiveSheet.Name & "'."

Please help.

Thanks.

 

[Joel]

sCells is not defined. You are going to have to set the range by changint
the A1 and E5.

from
MsgBox "You have removed " & cCount & " check marks in highlighted cells "
'" & sCells.Name & "' of the Worksheet '" & ActiveSheet.Name & "'."
to
MsgBox "You have removed " & cCount & " check marks in highlighted cells "
& "' of the Worksheet '" & ActiveSheet.Name & "'."

 

[Please Help]

Joel,

The range is pretty much any cell on the sheet, not just A1 and E5.
Meaning, we could have shapes in cells A1, E5, G100:I110, etc.

From your post, you asked me to change the MsgBox. Does it mean the new one
will not reference the cells where we are removing the shapes? Is it
possible to reference them in the Msgbox?

Thanks.

 

[Please Help]

May be, I didn't clearly posted. The active sheet may contain 100 shapes at
various cells. I may, however, want to remove 10 shapes out of 100 by
selecting (highlighting) the range where I want to remove the shapes.

Therefore, I don't think we can set a specific range in the code.

Thanks.

 

[Joel]

I modified the code to work off selected cells


Sub test()

Dim cMarks As Shape
Dim sCells As Range
Dim cCount As Integer

Set myRange = Selection
myRows = myRange.Rows.Count
LastRow = myRange.Row + myRows - 1
myCols = myRange.Columns.Count
Lastcol = myRange.Column + myCols - 1
Set LastCell = Cells(LastRow, Lastcol)

RLeft = myRange.Left
RTop = myRange.Top
RRight = LastCell.Left + LastCell.Width
RBottom = LastCell.Top + LastCell.Width

For Each cMarks In ActiveSheet.Shapes
If cMarks.Type = 13 Then
If cMarks.Top >= RTop And _
cMarks.Top <= RBottom And _
cMarks.Left >= RLeft And _
cMarks.Left <= RRight Then

cCount = cCount + 1
cMarks.Delete
End If
End If
Next cMarks
MsgBox "You have removed " & cCount & " check marks in highlighted cells
" _
& myRange.Address & "' of the Worksheet '" & ActiveSheet.Name & "'."
End Sub

 

[Please Help]

Joel,

Thank you again for your patience and your continuing help.

I think we are almost there. When I try your latest code, I got no error
message, and it removed the shapes. However, it does not remove all the
shapes.

For example, if I selected the cells B4:E9, B17, E18 and H11. It removed
the shapes only in the cells B4:E9. There were total of 9 shapes, and cells
B4:B9 has 6 shapes. I also tried it by selecting 2 large range (F4:I11 and
D16:F22) of cells (instead of one large range and individual cells like the
first example), and it deleted the shapes in the first range.

Based on the testing, the macro only removes the shapes in the first cell or
first group of cells. The shapes of the rest of selected cells (selecting
using the Ctrl key) do not get removed.

Thanks.

 

[Joel]

Here is a simple modification to handle all seleted areas.


Sub test()

Dim cMarks As Shape
Dim sCells As Range
Dim cCount As Integer

For Each myRange In Selection.Areas

myRows = myRange.Rows.Count
LastRow = myRange.Row + myRows - 1
myCols = myRange.Columns.Count
LastCol = myRange.Column + myCols - 1
Set LastCell = Cells(LastRow, LastCol)

RLeft = myRange.Left
RTop = myRange.Top
RRight = LastCell.Left + LastCell.Width
RBottom = LastCell.Top + LastCell.Width

For Each cMarks In ActiveSheet.Shapes
If cMarks.Type = 13 Then
If cMarks.Top >= RTop And _
cMarks.Top <= RBottom And _
cMarks.Left >= RLeft And _
cMarks.Left <= RRight Then

cCount = cCount + 1
cMarks.Delete
End If
End If
Next cMarks
MsgBox "You have removed " & cCount & _
" check marks in highlighted cells " _
& myRange.Address & "' of the Worksheet '" & _
ActiveSheet.Name & "'."
Next myRange
End Sub

 

[Please Help]

Joel,

This new code removes all the shapes in the cells selected. However,
instead of removing all the shapes and showing the message all at once,
removal is done based on each group of cells selected. For example, if I
have selected 4 groups of cells (using Ctrl key), the macro will remove 4
times and show message four times for each group of cells. In addition, the
counter (cCount) within the message is not counting correctly. It seems
double after removing 2nd group of shapes (cells).

Please help. Thank you very much for your help and patience.