I would like to delete all the shapes from my sheet. They have the same ID.
I found two codes:
The first one:
Public Sub ActiveShapes()
Dim ShpObject As Variant
If TypeName(Application.Selection) = "Firestop" Then
Set ShpObject = Application.Selection
ShpObject.Delete
Else
Exit Sub
End If
End Sub
is not working. There are no errors, but also no reaction at all.
The second one:
Selecting a shape in Excel with VBA
Sub Firestopshapes()
ActiveSheet.Shapes("Firestop").Delete
End Sub
works, but remove only one by one element. In my event, all the elements have the "Firestop" ID. I would like to make them all deleted at once. How can I do that?
The issue is thet If TypeName(Application.Selection) = "Firestop" Then is never true. Have a look into the TypeName function does not return the name of the Application.Selection but instead it returs what type Application.Selection is. Here it probably returns Object because a shape is an object.
Actually names are unique. You cannot add 2 shapes with the same name. That is why ActiveSheet.Shapes("Firestop").Delete only deletes one shape.
There seems to be a bug that when you copy a named shape 2 shapes with the same name exist (which should not be possible). You can get around this by deleting that shape in a loop until you get an error (no shape with that name is left).
On Error Resume Next
Do
ActiveSheet.Shapes("Firestop").Delete
If Err.Number <> 0 Then Exit Do
Loop
On Error GoTo 0 'don't forget this statement after the loop
It is not recommended to use On Error Resume Next often. We recommend using it only when it is indispensable.
Sub test()
Dim shp As Shape
Dim Ws As Worksheet
Set Ws = ActiveSheet
For Each shp In Ws.Shapes
If shp.Name = "Firestop" Then
shp.Delete
End If
Next shp
End Sub
Related
Im trying to manage pictures with VBA and im having some trouble
I have an Excel spreadsheet with a picture that has a custom name "Flower"
When I copy and paste, the new image keeps the same name "Flower"
I added a macro that when I click on the picture, it tells me which picture im clicking.
Sub ImageClicked()
' ImageClicked
shapeID = ActiveSheet.Shapes(Application.Caller).ID
MsgBox (shapeID)
End Sub
But the problem is that when I click on both images, the output is the same, it shows the same ID.
When I delete the first original image and click on the second image, the showed ID changes.
Is anything that im doing wrong?
P.S. Ive already figured out that if my original shape is a "Rectangle 1", then the copied shape is "Rectangle 2" and there are no problems.
The issue you actually run into is that your shape names are not unique and VBA now picks the first shape it finds with that name. This is due to a bug in Excel that if you copy shapes their name is exactly the same while it should not possible to have duplicate names.
I came through this bug several times, so I wrote a code to easily fix that and ensure shape names are unique. Sometimes you are not in control over the copy/paste process because other users did that and still need unique names.
You can use the following code to ensure unique shape names in the active sheet.
Option Explicit
Public Sub MakeShapeNamesUniqueInActiveSheet()
MakeShapeNamesUnique InWorksheet:=ActiveSheet
End Sub
Public Sub MakeShapeNamesUnique(ByVal InWorksheet As Worksheet)
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
' collect all shape names and how often they occur
Dim Shp As Shape
For Each Shp In InWorksheet.Shapes
If Dict.Exists(Shp.Name) Then
Dict(Shp.Name) = Dict(Shp.Name) + 1
Else
Dict.Add Shp.Name, 1
End If
Next Shp
' check which need to be renamed (duplicates) and rename them
Dim Key As Variant
For Each Key In Dict.keys
If Dict(Key) > 1 Then ' rename only if dupicate names exist
Dim iCount As Long
iCount = 1
Dim iShp As Long
For iShp = 1 To Dict(Key)
Dim NewName As String
NewName = Key & iCount
' make sure already existing new names get jumped
Do While ShapeExists(NewName, InWorksheet)
iCount = iCount + 1
NewName = Key & iCount
Loop
InWorksheet.Shapes(Key).Name = NewName ' rename the shape
iCount = iCount + 1
Next iShp
End If
Next Key
End Sub
Public Function ShapeExists(ByVal ShapeName As String, ByVal InWorksheet As Worksheet) As Boolean
' Test if a shape exists in a worksheet
On Error Resume Next
Dim Shp As Shape
Set Shp = InWorksheet.Shapes(ShapeName)
On Error GoTo 0
ShapeExists = Not Shp Is Nothing
End Function
For example if you have the following shape names in your sheet
Flower
Flower
Flower
Flower
Flower2
Bus
Car
Car
Car
After using the code the got renamed to
Flower1
Flower3
Flower4
Flower5
Flower2
Bus
Car1
Car2
Car3
Note that the renaming algorithm detects if renaming is necessary. For example Bus didn't need to be renamed as it was unique already. Also it detects that Flower2 already existed and jumps that number 2 when renaming the 4 Flower shapes so you end up with Flower1…5 otherwise you would end up with 2 Flower2 shapes.
The following code snippet can be used for debugging to list all the shape names and check them quickly:
Public Sub ListAllShapeNamesInActiveSheet()
ListAllShapeNames InWorksheet:=ActiveSheet
End Sub
Public Sub ListAllShapeNames(ByVal InWorksheet As Worksheet)
Dim Shp As Shape
For Each Shp In InWorksheet.Shapes
Debug.Print Shp.Name
Next Shp
End Sub
I have a set of shapes, which can be deleted.
However if at least one of them is deleted, then I am getting an error, that the object under the specified name wasn't found.
Basically I would like to make a comment after all, informing me, that all of the shapes have been already deleted.
My code looks like this so far:
Sub Civremov()
ActiveSheet.Shapes("Tobyshape").Delete
ActiveSheet.Shapes("Toby").Delete
ActiveSheet.Shapes("Upturnshape").Delete
ActiveSheet.Shapes("Upturndesc").Delete
ActiveSheet.Shapes("Duct1").Delete
ActiveSheet.Shapes("Duct2").Delete
End Sub
Now, when I attempt to delete these elements again, the errors says, that the object under a specified name wasn't found.
I would like to make a textbox like this:
Msgbox("You have already deleted all civil features").
How can I do this?
You could catch an error, however personally I usually like to loop over shapes, check their properties (name in your case) and act accordingly. You could opt to delete shapes when their name is found in a certain array of names?
For example:
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim arr As Variant: arr = Array("Tobyshape", "Toby", "Upturnshape", "Upturndesc", "Duct1", "Duct2")
For Each shp In ws.Shapes
If IsNumeric(Application.Match(shp.Name, arr, 0)) Then
shp.Delete
End If
Next
Msgbox "All relevant shapes are deleted." 'Optional
End Sub
If we are speaking of a certain type of shape, you could also include that check into your For loop to minimize the times we call Application.Match
I'm having issues with deleting a range of cells that contains ActiveX command buttons in it, as the code below will throw an error 1004 "Application-defined or object-defined error" on the intersect part when debugging.
Sub DeleteShapes()
Dim rng As Range
Dim sh As Shape
Set rng = Range("I7:K61")
With Sheets("ADB")
For Each sh In .Shapes
If Not Intersect(sh.TopLeftCell, .Range(rng)) Is Nothing Then
sh.Delete
End If
Next
End With
End Sub
The sheet is not locked, and I made sure that all cells within the ranges are not locked as well. No merged cells too. I've tried other combinations of codes, but it still results in that error 1004. The code is in a module.
Strange thing is, if I add a code to ignore the error, it deletes the buttons without issues. However, a strange issue popped up, wherein the dropdown box from data validations fail to show up after deleting the buttons. The only way for it to show up is to save the workbook. Deleting the buttons after saving causes the disappearance of the dropdown again.
Any solutions to this?
EDIT: It looks like I'm experiencing some sort of "Phantom drop down" object with Type 8 based on VBasic2008's code. I've created a new sheet and tried to copy some of the old ones, then it persisted again.
Further experimentation shows that it's coming from my Data Validation cells. Yet strangely enough, removing the data validation doesn't remove the drop down object. Clearing the entire sheet causes the object to still persist. I had to delete the sheet to get rid of it..
Is Data Validation being considered a Form Control? It shouldn't be.. right?
EDIT: How I generate my buttons
Public Sub GenerateButtons()
Dim i As Long
Dim shp As Object
Dim ILeft As Double
Dim dblTop As Double
Dim dblWidth As Double
Dim dblHeight As Double
Dim lrow As Long
lrow = Cells(Rows.count, 1).End(xlUp).Row
With Sheets("ADB")
ILeft = .Columns("I:I").Left
dblWidth = .Columns("I:I").Width
For i = 7 To lrow
dblHeight = .Rows(i).Height
dblTop = .Rows(i).Top
Set shp = .Buttons.Add(ILeft, dblTop, dblWidth, dblHeight)
shp.OnAction = "Copy1st"
shp.Characters.Text = "Copy " & .Cells(i, 6).Value
Next i
End With
End Sub
Shapes
In VBE's object browser search for msoShapeType and you will notice that
there are several shape types. In your case probably:
msoFormControl (8) - Drop downs
msoOLEControlObject (12) - Buttons and stuff.
Anyway try this code first to determine what you want to delete.
Sub ShapeTypes()
Dim shshape As Shape
Const c1 = " , "
Const r1 = vbCr
Dim str1 As String
str1 = "Shape Types in ActiveSheet"
For Each shshape In ActiveSheet.Shapes
str1 = str1 & r1 & Space(1) & shshape.Name & c1 & shshape.Type
Next
Debug.Print str1
End Sub
The following code deletes all msoOLEControlObject typed shapes on the ActiveSheet (Which I am assuming you want to delete):
Sub ShapesDelete()
Dim shshape As Shape
For Each shshape In ActiveSheet.Shapes
If shshape.Type = 12 Then
shshape.Delete
End If
Next
End Sub
Finally your code:
Sub DeleteShapes()
Const cStrRange As String = "I7:K61"
Const cStrSheet As String = "ADB"
Dim sh As Shape
With Sheets(cStrSheet)
For Each sh In .Shapes
If sh.Type = 12 Then 'or msoOLEControlObject
On Error Resume Next
If Intersect(sh.TopLeftCell, .Range(cStrRange)) Then
If Not Err Then
sh.Delete
End If
End If
End If
Next
End With
End Sub
I still haven't figured out the reason behind the error, but it is handled and all the buttons get deleted.
New Version:
Sub DeleteShapes()
Const cStrRange As String = "I7:K61"
Const cStrSheet As String = "ADB"
Dim sh As Shape
With Sheets(cStrSheet)
For Each sh In .Shapes
If sh.Type = 8 Then 'or msoFormControl
On Error Resume Next
If Not Intersect(sh.TopLeftCell, .Range(cStrRange)) Is Nothing Then
If Left(sh.Name,4) = "Butt" then
sh.Delete
End If
End If
End If
Next
End With
End Sub
No need for error handling since the WRONG Intercept line was causing the error.
I have an Excel calendar in which certain cells have a shape on them. I wish to be able to see which cells have a shape and then be able to extract some data.
I've searched a bit and found that the best option was to use TopLeftCell.Row but it seems there's an error on my code. I've copied a code and tried to adapt it, here it is:
Sub ActiveShapeMacro()
Dim ActiveShape As Shape
Dim UserSelection As Variant
'Pull-in what is selected on screen
Set UserSelection = ActiveWindow.Selection
'Determine if selection is a shape
On Error GoTo NoShapeSelected
Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
On Error Resume Next
'Do Something with your Shape variable
Cells(Sheet1.Shapes(ActiveShape).TopLeftCell.Row, Sheet1.Shapes(ActiveShape).TopLeftCell.Column).Address
MsgBox (ActiveShape.Address)
Exit Sub
'Error Handler
NoShapeSelected:
MsgBox "You do not have a shape selected!"
End Sub
Thank you for your help! :)
the error is in:
Sheet1.Shapes(ActiveShape)
where Shapes is waiting for a string (the shape name) while you're providing an Object (the shape itself)
so use:
'Do Something with your Shape variable
MsgBox Cells(ActiveShape.TopLeftCell.Row, ActiveShape.TopLeftCell.Column).Address
that can be simplified to:
MsgBox ActiveShape.TopLeftCell.Address
Moreover change:
On Error Resume Next
to:
On Error GoTo 0
and keep watching what's happening in there...
Here is an easy way to determine if a range or Shape has been selected and if it is a Shape, where it is:
Sub skjdkffdg()
Dim s As Shape, typ As String
typ = TypeName(Selection)
If typ = "Range" Then
MsgBox " you have a range selected: " & Selection.Address
Else
Set s = ActiveSheet.Shapes(Selection.Name)
MsgBox "you have a Shape selected: " & s.TopLeftCell.Address
End If
End Sub
This assumes that the only things on the worksheet are Shapes and Ranges.
I have a file that someone made and I was tasked with simply adding an autoupdater function that updates the cell next to the dropdown menu.
The way the dropdown menu is created is by going to data validation and selecting list and make list in cell. The values are read from elsewhere.
Now, what I tried was to loop over all shapes like this:
Dim dd As DropDown
Dim i As Integer
Debug.Print Sheet1.DropDowns.Count
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Dim s As Shape
For Each s In ws.Shapes
Debug.Print CStr(s.Type)
Next
Next
End Sub
This prints the following:4 is a comment, 8 is a control form
444444444444444444444444444
8
So even though I have many drop down menus none come out when I loop over them.
I wanted to make it so that anyone can add a dropdown box and my code would attach an OnAction Sub that fills in the cell next to the dropdown box so the user can add as many boxes they want, but they have to only remember to keep the cell next to it, to the right for example, empty as it will be overridden.
Dim sh As Shape
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
For Each sh In ws.Shapes
If sh.Type = msoFormControl Then
If sh.FormControlType = xlListBox Then
sh.OLEFormat.Object.OnAction = "UpdateLBCell"
End If
End If
Next
Next
The original code above causes an object error on the innermost line.
Am I just stupid or is it not possible to loop over these dropdown boxes?
If it is impossible, can I make some other dropdown single select boxes that fit inside a cell? Combobox I tried, but they lie on top and dont match.
Any insight in alternative ways to do this is very appreciated as well.
I put a list validation on a few cells, then ran this code
Sub Test()
Dim dd As DropDown
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Dim s As Shape
For Each s In ws.Shapes
Debug.Print CStr(s.Type), s.Top, s.Left
s.Visible = msoCTrue '<<<<
Next
Next
End Sub
Before and after (yellow cells have data validation):
So it seems as though if you have a "list" data validation set up, Excel manages a single (normally invisible and empty) drop-down which is typically positioned at the current active cell. It's only made visible when that's also one of the cells with validation set up.
EDIT: here's an example of how you could handle updates to cells with drop-down DV lists in a generic way -
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
On Error GoTo haveError
Application.EnableEvents = False
For Each c In Target.Cells
If HasDVList(c) Then
c.Offset(0, 1) = Now
End If
Next c
haveError:
Application.EnableEvents = True
End Sub
'does a cell have DV list?
Function HasDVList(rng As Range)
Dim v
On Error Resume Next
v = rng.Cells(1).Validation.Type
On Error GoTo 0
HasDVList = (v = 3)
End Function
The Shape should be Visible, whether the cell is "clicked-on" or not. I put a single DV dropdown on a sheet and ran:
Sub ShapeLister()
Dim s As Shape
For Each s In ActiveSheet.Shapes
MsgBox s.Type & vbCrLf & s.Name
Next s
End Sub
and got:
Try this on a fresh worksheet and tell us what you see.