I have submitted question on Excel - Autoshape get it's name from cell (value) but every my reply get's deleted so I will open new one.... please don't delete now
This is file and works fine but I have to use now only square shapes
File
in way home1, home2, office1, office2, stair1, stair2.. to indicate locations that if user change home in the list to building it changes only squares that have that name and not others...? or office to elevator only office shapes are updated
this column A with shapes can be deleted and leave only B name and C number as I use only squares
sorry don't know so much about VBA
check image
image
This can be achieved with a _Change event on the shapes worksheet. Add this to the Shapes sheet vba
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim shp As Shape
Dim nw As Variant
Dim old As Variant
' in case there is an error...
On Error GoTo CleanUp
Set rng = Intersect(Target, [Shape])
If Not rng Is Nothing Then
' Save new name
nw = Target
' Prevent events firing while we change sheet values
Application.EnableEvents = False
' Get previous name
Application.Undo
old = Target
' Restore new name
Target = nw
' Rename selected Shapes
For Each shp In Me.Shapes
If shp.Name Like old & "#*" Then
shp.Name = nw & Mid(shp.Name, Len(old) + 1)
End If
Next
End If
CleanUp:
' Re-enable events
Application.EnableEvents = True
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'm trying to use VBA in Excel to convert a bunch of pictures in a column (one per cell) to a pop up comment image instead so that the sheet is more easily readable.
I can find the image I need by iterating through the shapes, and I can set this as an object; but I can't seem to use that onject to populate the comment field. It seems to be looking for a true file path instead.
I don't particularly want to have to save each image and then reload it, seems kind of pointless.
For Each Pic In ActiveSheet.Shapes
If Pic.TopLeftCell.Address = ActiveCell.Address Then
If Pic.Type = msoPicture Then
Pic.Select
Application.ActiveCell.AddComment.Shape.Fill.UserPicture **(ActiveSheet.Shapes(Pic.name))** 'if I use a path here its okay
'SelectPictureAtActiveCell = name
Exit For
End If
End If
Next
any thoughts?
CJ
I think you want to show one image if you select a specific cell then
See
Making shapes invisible/visible in excel through VBA
with
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Macro1
End Sub
You can make images hide and show using
ActiveSheet.Shapes("ImageName").Visible = False or True
for example when you click on cell A1 first image is hidden else all images are visible
Sub Macro1()
Dim shp As Shape
If ActiveCell.Address = "$A$1" Then
For Each shp In ActiveSheet.Shapes
ActiveSheet.Shapes(1).Visible = False
' or you can use image name as
'ActiveSheet.Shapes("ImageName").Visible = False
'shp.Visible = False
Next
Else
For Each shp In ActiveSheet.Shapes
shp.Visible = True
Next
End If
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.
I have a Vlookup set up from a selection in a drop down window. This is easy. What I am finding difficult is once I select a name, I need their image to show up in an area of my worksheet. Any help would be appreciated. I am using Excel 2010. Thank you.
If you put a picture into your worksheet in the location that you want then you can just use that pictures properties to insert a new picture (after deleting the old one). Alternatively, you could set the size properties as constants. Paste this code into a module:
Const PicturePath = "C:\Users\Public\Pictures\Sample Pictures\"
Sub ChangePicture(PictureName)
Dim p As Picture
Dim ptop, pleft, pwidth, pheight
On Error GoTo errorhandler
For Each p In ActiveSheet.Pictures
ptop = p.Top
pleft = p.Left
pwidth = p.Width
pheight = p.Height
p.Delete
Next p
ActiveSheet.Pictures.Insert (PicturePath & PictureName)
For Each p In ActiveSheet.Pictures
p.Top = ptop
p.Left = pleft
p.Width = pwidth
p.Height = pheight
Next p
Exit Sub
errorhandler:
MsgBox "Error loading file, check the filename to make sure it is valid.", _
vbCritical, "ChangePicture"
End Sub
then add this code to the worksheet with your picture names
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Value <> "" Then
ChangePicture Target.Value
End If
End Sub
In the worksheet, if you have a list of picture names like
Desert.jpg
Jellyfish.jpg
Koala.jpg
then when you click on one, the code will run and insert your new picture in place of the old one. This should at least get you started, and you can tweak the code to suit your purposes. Make sure you have a picture in your worksheet, that is the size and position that you want, and then the new picture will be in the same place, and the same size.