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

ashni

New Member
Joined
Jun 13, 2016
Messages
32
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

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
Office Version
2016
Platform
Windows
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?
 
Last edited:

ashni

New Member
Joined
Jun 13, 2016
Messages
32
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

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
Office Version
2016
Platform
Windows
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)

Code:
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
 
Last edited:

ashni

New Member
Joined
Jun 13, 2016
Messages
32
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

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
Office Version
2016
Platform
Windows
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) :
Code:
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
 
Last edited:

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
7,493
Office Version
2016
Platform
Windows
Editing time up

Ignore the previous code and try the following :
Code:
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

New Member
Joined
Jun 13, 2016
Messages
32
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…
 
Last edited:

ashni

New Member
Joined
Jun 13, 2016
Messages
32
OHH!!! ignore my last post Jaafar!!!
It is working fine. Thank you so much for the help!!!
 

Forum statistics

Threads
1,082,275
Messages
5,364,178
Members
400,785
Latest member
Mahar92

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top