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.
Related
I have excel Project that includes pictures. I have userform that has ImageBox. This form shows pictures dynamically according to row number with using selection change event.
This event triggered when cell selection change. But i want to triggered this event by clicking on shape. Is there any solution for that?
Please see image.
These are codes for cell selection change event.
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
Dim Pic As Shape
For Each Pic In ActiveSheet.Shapes
If Pic.TopLeftCell.Row = ActiveCell.Row Then
If Pic.Type = msoPicture Then
Pic.Select
Dim sheetName As String, MyPicture As String, strPicPath As String
sheetName = ActiveSheet.Name
MyPicture = Selection.Name
strPicPath = SavedPictureTo(MyPicture)' This function save image
Load ImageViever 'ImageViewer is UserForm name
With ImageViever
.Image1.Picture = LoadPicture(strPicPath)
.Show vbModeless
End With
Exit For
End If
End If
Next
Application.ScreenUpdating = True
End Sub
As written in the comments, you can assign a (parameterless) Sub to a shape that is executed when a shape is clicked.
In Excel, you can assign the macro by right-clicking on the shape and select "Assign macro".
With VBA, you write the name of the macro to the OnAction-property of the shape:
Dim sh As Shape
For Each sh In ActiveSheet.Shapes ' <-- Select the sheet(s) you need
sh.OnAction = "HelloWorld" ' <-- Change this to the name of your event procedure
Next
If you want to know which shape was clicked, you can use the Application.Caller property. When the macro was called by clicking on a shape, it contains the name of that shape.
Sub helloWorld()
Dim sh As Shape
On Error Resume Next
Set sh = ActiveSheet.Shapes(Application.Caller)
On Error GoTo 0
If sh Is Nothing Then
MsgBox "I was not called by clicking on a shape"
Else
MsgBox "Someone clicked on " & sh.Name
End If
End Sub
How can I resolve the type mismatch error (indicated)?
If I want to restrict the sub to the specified ranges, why would changing If Not Intersect to If Intersect exit the sub?
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sH As Object, ByVal Target As Range, Cancel As Boolean)
' Exclude specified ranges
Dim rExcl(1) As Range, i As Integer, r As Range
Set rExcl(0) = Range("Table1"): Set rExcl(1) = Range("Table2")
For i = 0 To 1
For Each r In rExcl(i)
If r.Parent Is sH Then
If Not Intersect(Target, r) Is Nothing Then Exit Sub ' Type mismatch error
End If
Next
Next
End Sub
It seems that the purpose of the code posted is to validate if the user double-clicked a cell within any of the Tables (i.e.: Table1 or Table2), if so then Exit Sub.
In regards to the questions:
1. How can I resolve the type mismatch error (indicated)?
If Not Intersect(Target, r) Is Nothing Then Exit Sub ' Type mismatch error
Unfortunately, this error cannot be reproduced. This error is triggered when the data type of a variable differs to what is required. In this case it seems "almost" impossible because:
Intersect expects ranges and both variables (Target and r) are defined as ranges.
Intersect returns an object (range) which is what Is Nothing is expecting.
Intersect could also return an Error when the ranges have different parents, but that situation is already taken care by this line If r.Parent Is Sh Then.
The proposed solution includes a method to debug this error when it happens.
2. If I want to restrict the sub to the specified ranges, why would changing If Not Intersect to If Intersect exit the sub?
This is happening because the code posted is validating the ranges cell by cell, therefore if the user double-clicked the last cell of the table then the code compares the first cell and because there is no intersection the code exits the sub.
Bear in mind that the purpose is to validate if the double-clicked cell belongs or not to any of the tables ( i.e.: “ranges intersection”, if one cell intersect or not with a range, then the entire range intersects or not), as such there is no need to validate each cell, instead validate the entire range at once.
Proposed Solution:
Note that the ERR_Intersect subroutine should be just temporary, it is include to help analyze the mismatch error.
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim rExcl(1) As Range, vRng As Variant
Set rExcl(0) = Range("Table1")
Set rExcl(1) = Range("Table2")
For Each vRng In rExcl
Rem Validate Worksheet
If vRng.Parent Is Sh Then
Rem Validate Target
On Error Resume Next
If Not Intersect(Target, vRng) Is Nothing Then
blErr = Error.Number <> 0
On Error GoTo 0
If blErr Then GoTo ERR_Intersect
Exit Sub
End If
On Error GoTo 0
End If: Next
Exit Sub
ERR_Intersect:
Debug.Print vbLf; "Error: "; Err.Number; " - "; Err.Description
Debug.Print "Object"; Tab(11); "TypeName"; Tab(21); "Address"; Tab(31); "Parent"
Debug.Print "Target"; Tab(11); TypeName(Target);
Debug.Print Tab(21); Target.Address(0, 0);
Debug.Print Tab(31); Target.Parent.Name;
Debug.Print
Debug.Print "vRng"; Tab(11); TypeName(vRng);
Debug.Print Tab(21); vRng.Address(0, 0);
Debug.Print Tab(31); vRng.Parent.Name;
Debug.Print
MsgBox "Error: " & Err.Number & " - " & Err.Description & vbLf & _
vbTab & "See Immediate Window for details."
Exit Sub
End Sub
Your code works without any problem in the way you presented and it will also work in the way you try understanding, but with a different meaning, respectively:
You should understand that Intersect returns a 'Range' and the above code checks if this Range exists. In words, this part should be understood as "If the two ranges are intersecting".
This part If Intersect(Target, r) Is Nothing Then Exit Sub means "If the two ranges are not intersecting" (such an eventual intersection does not exist).
No any 'Type mismatch' should exist in both mentioned variants, if you are referring to real tables. It may appear if you named a different object (not a range) as 'TableX'...
Please, try inserting the next code line:
Debug.Print TypeOf rExcl(0) Is Range, TypeOf rExcl(1) Is Range: stop
after:
Set rExcl(0) = Range("Table1"): Set rExcl(1) = Range("Table2")
What does it return in Immediate Window?
Edited:
You could not 'reproduce the error in Debug.Print' because that line is not even reached...
There is a conflict in your workbook. There is the Workbook event you show us in the question and another Worksheet_BeforeDoubleClick event which tries closing the Excel application if the double clicked cell is the one you claim as being 'strange'...
The sheet event is triggered first and the Workbook one is not triggered anymore, since the code tries quitting Excel application. Try put Exit Sub as the first code line in the Worksheet event and try the double click again.
Nothing wrong will happen after that...
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
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 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.