Wait Until new shape selected

[Scrapyard]

Good Evening,

I'm a novice at best. I'm looking for a faster way to name shapes that make up a large map using a given array.

Given:
- An array "Districts," which has more than 300 text strings (district names) stored in it
-- The district array has no spaces or special characters in it
- A map of more than 300 freeform shapes

Desired Effect:
- A macro that:
-- Uses for/next (or other method) to incrementally increase "n" to ubound(Districts)
-- cell(1, 1).value = Districts( n )
-- waits until I select a freeform shape (This is the part I don't have the first clue on how to execute)
-- names that shape I select the same as the district name
-- next n (or other method)

I appreciate any assistance you could provide!

 

[John_w]

See if this code works for you. It uses a timer (Application.OnTime) to call a procedure (Rename_Selected_Shape) every second to monitor the active sheet and determine if a freeform shape has been selected by the user. If so, it renames that shape to the value of cell A1 (the current value of the Districts array) and changes A1 to the next District. The timer is restarted until the end of the Districts array has been reached.

Note that the code first renames all the freeform shapes by adding a number suffix to the existing shape name - the reason for this is explained in the code.

To use the code, just put the district names in the Districts array and run the Initialise procedure.

Option Explicit

Public Const OnTimeInterval As String = "00:00:01"
Public Const OnTimeProcedureName As String = "Rename_Selected_Shape"

Dim NextCheckTime As Date
Dim Districts As Variant
Dim DistrictIndex As Long


Public Sub Initialise()
    
    Districts = Array("Dist1", "Dist2", "Dist3", "Dist4", "Dist5", "Dist6", "Dist7", "Dist8", "Dist9")
    DistrictIndex = 0
    
    'Every shape must have a name which isn't the same as any District.  Otherwise when the user selects a shape and the OnTime macro renames it there will
    'be 2 shapes with the same name and Excel will automatically select the first shape it finds with that name and if that is not the same shape that the
    'user selected the OnTime macro will incorrectly rename that shape and others that Excel automatically selects.
    
    Rename_All_Shapes
    
    Application.Run OnTimeProcedureName
    
End Sub


Public Sub Start_Timer()
    NextCheckTime = Now + TimeValue(OnTimeInterval)
    Application.OnTime EarliestTime:=NextCheckTime, Procedure:=OnTimeProcedureName, Schedule:=True
End Sub


Public Sub Stop_Timer()
    On Error Resume Next
    Application.OnTime EarliestTime:=NextCheckTime, Procedure:=OnTimeProcedureName, Schedule:=False
    On Error GoTo 0
End Sub


Private Sub Rename_All_Shapes()
    
    Dim thisShape As Shape
    Dim n As Long
    
    'Add number suffix to all freeform shapes
    
    n = 0
    For Each thisShape In ActiveSheet.Shapes
        If thisShape.Type = msoFreeform Then
            n = n + 1
            thisShape.Name = thisShape.Name & "_" & n
        End If
    Next

End Sub


Public Sub Rename_Selected_Shape()

    Dim SelectedShape As Shape
    Static PreviousShape As Shape
        
    'Put the current District in A1
    
    If DistrictIndex <= UBound(Districts) Then
        ActiveSheet.Range("A1").Value = Districts(DistrictIndex)
    End If
    
    'Get the currently selected shape, if any
    
    Set SelectedShape = Nothing
    On Error Resume Next
    Set SelectedShape = ActiveSheet.Shapes(ActiveWindow.Selection.Name)
    On Error GoTo 0
    
    If Not SelectedShape Is Nothing Then
                            
        'If the freeform shape is different to the previously selected shape and there are more Districts
        
        If SelectedShape.Type = msoFreeform And Not SelectedShape Is PreviousShape And DistrictIndex <= UBound(Districts) Then
            
            'Rename the selected shape as the current District and remember it as the previous shape
            
            SelectedShape.Name = Districts(DistrictIndex)
            DistrictIndex = DistrictIndex + 1
            If DistrictIndex <= UBound(Districts) Then
                ActiveSheet.Range("A1").Value = Districts(DistrictIndex)
            End If
            Set PreviousShape = SelectedShape
            
        End If
        
    End If
    
    'If there are more Districts restart the timer
    
    If DistrictIndex <= UBound(Districts) Then
        Start_Timer
    Else
        Stop_Timer
        MsgBox "Done - all shapes renamed", vbInformation, "Rename Shapes"
    End If
    
End Sub

 

[Scrapyard]

Thank you! I cannot express how grateful I am for your assistance!

This is vastly more complicated than I thought.

 

[Scrapyard]

Sorry, but I'm running into one or more minor errors:

Districts = Sheets("Districts").Range("H2:H411").Value
- This is producing a subscript out of range error.

I tried using a do/loop and offset to name Districts(1 to 410), which worked until I went to another sub, which also produced a subscript out of range error.
- It does at the line: If DistrictIndex <= Ubound(Districts) then ...

I'm fairly sure this is a definitions issue, but I am uncertain how to remedy it.

 

[jolivanes]

Are you going to select the freeforms in order of the array? Hard to do with >300 names.
So if you select a freeform, how does it know what the district name it should get is?

Does it work if you output the array into a column, select a name in that column and then click on a Shape to give it that name?
Like so
Run this first. You can delete the code later.

Sub Add_Code_To_Shapes()
Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        shp.OnAction = "Get_Name"
    Next shp
End Sub

Sub Get_Name()
    ActiveSheet.Shapes(Application.Caller).Name = ActiveCell.Value   
End Sub

As soon as you select a shape it will get the name of the active cell

 

[John_w]

Districts = Sheets("Districts").Range("H2:H411").Value
- This is producing a subscript out of range error.

Not on that line though - the error occurs elsewhere in the code. Click Debug on the error message and the following line is highlighted in yellow:

        ActiveSheet.Range("A1").Value = Districts(DistrictIndex)

because when a range is assigned to a Variant a two-dimensional array is created of the row and column values in the range, even if there is only 1 row or 1 column. The Districts array is therefore two-dimensional and 2 array subscripts must be specified, not 1, in all references to it. However there is a VBA trick that turns a two-dimensional array into a one-dimensional array, so that the above line doesn't need changing. Furthermore, with an array created from a range the subscript number starts at 1, not 0 that the code is using. Taken together, the only changes needed are in the Initialise routine:

Public Sub Initialise()
    
    Districts = Application.Transpose(Worksheets("Districts").Range("H2:H411").Value)
    DistrictIndex = 1
    
    'Every shape must have a name which isn't the same as any District.  Otherwise when the user selects a shape and the OnTime macro renames it there will
    'be 2 shapes with the same name and Excel will automatically select the first shape it finds with that name and if that is not the same shape that the
    'user selected the OnTime macro will incorrectly rename that shape and others that Excel automatically selects.
    
    Rename_All_Shapes
    
    Application.Run OnTimeProcedureName
    
End Sub

 

[Scrapyard]

Are you going to select the freeforms in order of the array? Hard to do with >300 names.
So if you select a freeform, how does it know what the district name it should get is?

Does it work if you output the array into a column, select a name in that column and then click on a Shape to give it that name?
Like so
Run this first. You can delete the code later.

Sub Add_Code_To_Shapes()
Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        shp.OnAction = "Get_Name"
    Next shp
End Sub

Sub Get_Name()
    ActiveSheet.Shapes(Application.Caller).Name = ActiveCell.Value 
End Sub

As soon as you select a shape it will get the name of the active cell

Yes, no matter how I look at this, it's a difficult task. I am forced to select 300+ freeforms and hope I don't accidently select the wrong one. However, in the end, this will save me from having to do it manually. The goal by the end of it is to change the properties (Fill Color and line color) of the freeforms according to user input.

 

[jolivanes]

Re: "hope I don't accidently select the wrong one". That is the big problem, isn't it.
It it was me, I would have another (empty) sheet and with code put all the current names in column A and the top left cell address of that same shape in the column beside it.
If there are no duplicate addresses you can use the top left cell as an indicator for each shape.
As a matter of fact, if the shapes are set to not move and size with cells you can make the cell sizes smaller till there are no more duplicate top left cell addresses.
With code, that would not take long and it would eliminate naming the shapes wrong.
You could then put the new name in another column and rename the shapes with offset. Something like "ActiveSheet.Shapes(Sheets("Sheet2").Range("A2").Value).Name = Sheets("Sheet2").Range("C2").Value"