show userform when i move a shape from one column to another

[ashni]

Hii!!
I have two columns in my worksheet where i have to move shapes inserted anywhere in column 1 to column 2.
whenever i do so i want a userform to appear in my sheet. There is only one text box and one submit button in userform.
whatever data i insert in that textbox that gets saved in sheet3 column B.

 

[Jaafar Tribak]

How many shapes do you have ?
Also, do you want the form to appear ONLY when the shape(s) are moved from Column1 to column 2 and not vice versa?

 

[ashni]

I have 4 to 5 shapes in each column. But i move shapes one by one.
yes. I want the form to appear ONLY when the shape is moved from Column1 to column 2 and not vice versa.

 

[Jaafar Tribak]

See if this works for you :

Place the following code in the ThisWorkbook Module and run the Workbook_Open event (This event will automatically run everytime the workbook is opened anyway)

Option Explicit

Private WithEvents CmbrsEvent As CommandBars
Private Const TargetSheet As String = "Sheet1" [B][COLOR=#008000]' <== change sheet as required[/COLOR][/B]


Private Sub Workbook_Open()
    Dim oShp As Shape
    
    For Each oShp In Sheets(TargetSheet).Shapes
        oShp.AlternativeText = oShp.Left & "*" & oShp.TopLeftCell.Column
    Next
    Set CmbrsEvent = Application.CommandBars
End Sub


Private Sub CmbrsEvent_OnUpdate()
    Dim ar() As String
    
    On Error Resume Next
    With Sheets(TargetSheet).Shapes(Selection.Name)
        If TypeName(Selection) <> "Range" Then
            ar = Split(.AlternativeText, "*")
            If ar(0) <> CStr(.Left) And ar(1) <> CStr(.TopLeftCell.Column) And ar(1) = "1" Then
                If .TopLeftCell.Column = 2 Then
                    MsgBox "You moved shape '" & Selection.Name & "' from:" & vbNewLine & "Column A to Column B", vbInformation
                    'UserForm1.Show  [B][COLOR=#008000]<== Display your UserForm here[/COLOR][/B]
                End If
            End If
        End If
        .AlternativeText = .Left & "*" & .TopLeftCell.Column
    End With
End Sub

The code assumes the shapes are located in Sheet1 ... Change the module level const TargetSheet as required

 

[ashni]

This code is showing me the userform just after i select any shape anywhere on any worksheet in the workbook.
Userform should not appear until I select and move shape from column1 (A) and place it in column2 i.e. (B)

 

[Jaafar Tribak]

Sorry, I forgot about shapes that may exist in other sheets

Try this modified code which will work for shapes on Sheet1 only ( Change in Red) :

Option Explicit

Private WithEvents CmbrsEvent As CommandBars
Private Const TargetSheet As String = "Sheet1" ' <== change sheet as required


Private Sub Workbook_Open()
    Dim oShp As Shape
    
    For Each oShp In Sheets(TargetSheet).Shapes
        oShp.AlternativeText = oShp.Left & "*" & oShp.TopLeftCell.Column
    Next
    Set CmbrsEvent = Application.CommandBars
End Sub


Private Sub CmbrsEvent_OnUpdate()
    Dim ar() As String
    
    On Error Resume Next
    With Sheets(TargetSheet).Shapes(Selection.Name)
        If TypeName(Selection) <> "Range"[B][COLOR=#ff0000] And Selection.Parent Is Sheets(TargetSheet)[/COLOR][/B] Then
            ar = Split(.AlternativeText, "*")
            If ar(1) = "1" Then ' ar(0) <> CStr(.Left) And ar(1) <> CStr(.TopLeftCell.Column) And ar(1) = "1" Then
                If .TopLeftCell.Column = 2 Then
                    MsgBox "You moved shape '" & Selection.Name & "' from:" & vbNewLine & "Column A to Column B", vbInformation
                    'UserForm1.Show  <== Display your UserForm here
                End If
            End If
        End If
        .AlternativeText = .Left & "*" & .TopLeftCell.Column
    End With
End Sub

 

[Jaafar Tribak]

Editing time up

Ignore the previous code and try the following :

Option Explicit

Private WithEvents CmbrsEvent As CommandBars
Private Const TargetSheet As String = "Sheet1" ' <== change sheet as required


Private Sub Workbook_Open()
    Dim oShp As Shape
    
    For Each oShp In Sheets(TargetSheet).Shapes
        oShp.AlternativeText = oShp.Left & "*" & oShp.TopLeftCell.Column
    Next
    Set CmbrsEvent = Application.CommandBars
End Sub


Private Sub CmbrsEvent_OnUpdate()
    Dim ar() As String
    
    On Error Resume Next
    With Sheets(TargetSheet).Shapes(Selection.Name)
        If TypeName(Selection) <> "Range" [B][COLOR=#ff0000]And Selection.Parent Is Sheets(TargetSheet)[/COLOR][/B] Then
            ar = Split(.AlternativeText, "*")
            If ar(0) <> CStr(.Left) And ar(1) <> CStr(.TopLeftCell.Column) And ar(1) = "1" Then
                If .TopLeftCell.Column = 2 Then
                    MsgBox "You moved shape '" & Selection.Name & "' from:" & vbNewLine & "Column A to Column B", vbInformation
                    'UserForm1.Show  <== Display your UserForm here
                End If
            End If
        End If
        .AlternativeText = .Left & "*" & .TopLeftCell.Column
    End With
End Sub

 

[ashni]

Thank you so much Jaafar for replying to my post..

Your code is working. but needs a little modification. And i cannot do it. I created a file which may give you clear idea about what i m trying to do. Can you tell me the fastest way to send my file to you. I think You can help me through it.

Code is working only when I select a shape in one column then run the macro-"Workbook_open" and then move the rectangle to column 2. As there are number of shapes i need to move this wont work smoothly.
I have to repeat this procedure for every shape I select and move to column 2
I want the userform to appear whenever I move any shape from column1 to column 2 Without having to run the macro everytime I select the shape I want to move.
Please tell me what more modification should I do with the code…

 

[ashni]

OHH!!! ignore my last post Jaafar!!!
It is working fine. Thank you so much for the help!!!