Moving & positioning shapes on sheet by selecting cell destination

[benntw]

Not sure if there is a way to do this without a touch screen panel and programming. I have a large spread sheet that gets displayed on a screen in our dispatch. Currently I grab a round rectangle shape with the equip id on it and drag it under appropriate job. Job titles change all the time. Once I place it I try and center it the best I can. I have around 100 shapes on the excel sheet to drag around. What I am hoping to do is select any of the shapes , one at a time, and then click the cell I want it to be placed at and have instantly move & center within the cell. Is this possible to even do with excel ? Thanks for your time.

 

[JoeMo]

I don't think you can do this exactly the way you described, because the shape will be deselected when you click on a cell. Here's an alternative you can try. It requires that you select the shape, then run the macro below which will ask you to enter a cell address to align the shape to.

You can assign the macro to a button on your sheet which can be clicked after the shape is selected. Note that the macro is set to make the shape size equal the cell size, but you can change that if desired to any width and height you want.

Sub MoveShape()
Dim shp As String, Adr As String
If TypeName(Selection) = "Rectangle" Then
    shp = Selection.Name
    Adr = InputBox("Enter cell address to place shape")
    If Adr = "" Then Exit Sub
    With ActiveSheet.Shapes(shp)
        .Top = Range(Adr).Top
        .Left = Range(Adr).Left
        .Width = Range(Adr).Width
        .Height = Range(Adr).Height
    End With
End If
End Sub

 

[MickG]

Try this:-
First place this code into a new BasicModule

[COLOR=black][FONT=Calibri]Option Explicit[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]Public Ob As Object[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]Sub oMove()[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]Set Ob =ActiveSheet.Shapes(Application.Caller)[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]End Sub[/FONT][/COLOR]

Then place this code into the Sheet Module where your shapes are.

[COLOR=black][FONT=Calibri]Private SubWorksheet_SelectionChange(ByVal Target As Range)[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]If Not Ob Is Nothing Then[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]    Ob.Left = Target.Left - Ob.Width / 2 + Target.Width / 2[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]    Ob.Top = Target.Top - Ob.Height / 2 + Target.Height / 2[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]    Set Ob = Nothing[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]End If[/FONT][/COLOR]
[COLOR=black][FONT=Calibri]End Sub[/FONT][/COLOR]

You will need to then right click each shape, Select "Assign Macro ".
Macro dialog box appears.
Look down the list of Macros, when you see the code called "oMove", click it and it then Click"OK" the code name will move to the Window at the top of the Box.
Do this for each shape.
Now when you click a Shape then Click a cell the Shape will move over the Cell.

 

[benntw]

When I placed this code in my sheet the Private SubWorksheet turned red. The debug said Compile Error: Expected: expression. It was highlighting " ByVal"

 

[MickG]

If you have not solved your problem, see this example file:-
https://app.box.com/s/5zthva7557ibt8oage26ife77b6tpfwm

 

[benntw]

MickG

That worked excellent. I really appreciate the help. I am still a rookie at VBA. Can I ask you for one more favor ? I tried putting a msg box with and failed really bad. It would move the object on " OK " and not move it on "Cancel" just fine. The problem I had was even after I clicked on another cell the message box kept coming up. With your example file it was awesome that it moved around. Then I though if I doesn't realize I selected one of the objects I could move it by mistake.

Again I really appreciate the help you have given me.

 

[MickG]

Try replacing the worksheet code with the below:-

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Ob Is Nothing Then
    If MsgBox("Move Shape ???", vbOKCancel + vbQuestion, "Accept/Reject") = vbOK Then
        Ob.Left = Target.Left - Ob.Width / 2 + Target.Width / 2
        Ob.Top = Target.Top - Ob.Height / 2 + Target.Height / 2
    End If
    Set Ob = Nothing
End If
End Sub

 

[benntw]

Now I see what I did wrong. Everything works perfect. Thank you very much.

 

[MickG]

You're welcome