How do I make a copy of a shape and place it in the same spot

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,019
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have code that moves some command buttons further down a spreadsheet as the rows in it are copied below. This means the buttons are now below the second copy of the rows. The only problem is that I want a divider (textbox4) to remain between the 2 copies of the rows. This code moves the command buttons to the right spot and I also need textbox4 moved in the same proportion but I need to leave a copy of it where it currently is. Can someone help me with the vba code please?

VBA Code:
Sub AddRows()
Dim Total As Range
    With ThisWorkbook.Worksheets("ACA_Quoting")
        '.Range("29:31").EntireRow.Insert
        '.Rows(29).Insert Shift:=xlShiftDown 'Inserts a row below the current table to create a buffer zone between the 2 tables.

        .Range("F29:H32").Copy .Range("F51")
        .Range("A8:I28").Copy .Range("A38") 'Pastes a copy of the table below current table between the bottom of the table and the totals
        '.Range("F30:H32").Offset(2, 0).Select 'This is the range of the totals that need to be moved down so the additional table can be pasted in
        '.Range("C7").Insert Shift:=xlDown
        
            .Shapes.Range(Array("cmdAddRatio")).Select
        .Shapes("cmdAddRatio").IncrementTop 505
            .Shapes.Range(Array("cmdGsign")).Select
        .Shapes("cmdGsign").IncrementTop 505
            .Shapes.Range(Array("cmdNoSign")).Select
        .Shapes("cmdNoSign").IncrementTop 505
            .Shapes.Range(Array("cmdSaveToPdf")).Select
        .Shapes("cmdSaveToPdf").IncrementTop 505
            .Shapes.Range(Array("cmdCustomSign")).Select
        .Shapes("cmdCustomSign").IncrementTop 505
            .Shapes.Range(Array("textbox4")).Select
        .Shapes("textbox4").IncrementTop 505
        
        
        '.Range("29:31").EntireRow.Insert
       
    End With
End Sub
 

Some videos you may like

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

rlv01

Well-known Member
Joined
May 16, 2017
Messages
771
Perhaps something like this.
VBA Code:
Sub AddRows()
    Dim Total As Range
    Dim WS As Worksheet
    Dim Sh As Shape, NewShape As Shape
    Dim TTop As Long
    Dim TLeft As Long

    Set WS = ThisWorkbook.Worksheets("ACA_Quoting")
    With WS
        '.Range("29:31").EntireRow.Insert
        '.Rows(29).Insert Shift:=xlShiftDown 'Inserts a row below the current table to create a buffer zone between the 2 tables.

        .Range("F29:H32").Copy .Range("F51")
        .Range("A8:I28").Copy .Range("A38")           'Pastes a copy of the table below current table between the bottom of the table and the totals
        '.Range("F30:H32").Offset(2, 0).Select 'This is the range of the totals that need to be moved down so the additional table can be pasted in
        '.Range("C7").Insert Shift:=xlDown
    End With

    For Each Sh In WS.Shapes
        Select Case Sh.Name
        Case "cmdAddRatio", "cmdCustomSign", "cmdGsign", "cmdNoSign", "cmdSaveToPdf"
            Sh.IncrementTop 505
        Case "txtMain"                                'name your first textbox, the one you want to move,  to something unique. I used "txtMain"
            TTop = Sh.Top                             'record position
            TLeft = Sh.Left
            Sh.IncrementTop 505                       'move it
            Sh.Copy                                   'make a copy
            WS.Paste
            Set NewShape = WS.Shapes(WS.Shapes.Count)    'pasted textbox is the last shape
            With NewShape
                .Top = TTop                           'move the copy to the previous position of txtMain
                .Left = TLeft
            End With
        End Select
    Next Sh
End Sub
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,019
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Thank you, that is great. I changed the area that is copied and now it works perfectly for one copy of the rows. This is the code now

VBA Code:
Sub AddRows()
    Dim Total As Range
    Dim WS As Worksheet
    Dim Sh As Shape, NewShape As Shape
    Dim TTop As Long
    Dim TLeft As Long

    Set WS = ThisWorkbook.Worksheets("ACA_Quoting")
    With WS
        '.Range("29:31").EntireRow.Insert
        '.Rows(29).Insert Shift:=xlShiftDown 'Inserts a row below the current table to create a buffer zone between the 2 tables.

        .Range("F29:H32").Copy .Range("F51")
        .Range("A8:V28").Copy .Range("A38")           'Pastes a copy of the table below current table between the bottom of the table and the totals
        '.Range("F30:H32").Offset(2, 0).Select 'This is the range of the totals that need to be moved down so the additional table can be pasted in
        '.Range("C7").Insert Shift:=xlDown
    End With

    For Each Sh In WS.Shapes
        Select Case Sh.Name
        Case "cmdAddRatio", "cmdCustomSign", "cmdGsign", "cmdNoSign", "cmdSaveToPdf"
            Sh.IncrementTop 505
        Case "txtMain"                                'name your first textbox, the one you want to move,  to something unique. I used "txtMain"
            TTop = Sh.Top                             'record position
            TLeft = Sh.Left
            Sh.IncrementTop 505                       'move it
            Sh.Copy                                   'make a copy
            WS.Paste
            Set NewShape = WS.Shapes(WS.Shapes.Count)    'pasted textbox is the last shape
            With NewShape
                .Top = TTop                           'move the copy to the previous position of txtMain
                .Left = TLeft
            End With
        End Select
    Next Sh
End Sub

  • The code leaves a copy of txtmain where it was originally but it won't make a second copy below the second copy of rows.
  • I also need to be able to press the button that runs the AddRows code multiple times and have it copy with the below the last copied row in the same proportions (I hope that makes sense)
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,019
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Just read it again and the second line above doesn't make sense.

  • The first line above that makes sense
    • The code leaves a copy of txtmain where it was originally but it won't make a second copy below the second copy of rows.
  • I need x number of copies to be possibly made.
  • Each copy must be in the same proportion of distance between the first and second copy.
  • A copy of txtmain must appear between each copy of rows to distinguish the end of the period.
 

rlv01

Well-known Member
Joined
May 16, 2017
Messages
771

ADVERTISEMENT

The code leaves a copy of txtmain where it was originally but it won't make a second copy below the second copy of rows.
That would be because your original post makes no mention of a second copy of the txtMain. The macro only creates one copy of txtMain each time it runs. Each time the macro is run, it will move txtMain down 505 (your number) from its current position and then make one copy of txtMain and put it where txtMain was located at the start of the macro execution. Run the macro once and there will be one copy. Run it 10 times, there will be 10 copies.

I need x number of copies to be possibly made.
Which the code will do. One new copy of txtMain is created each time you press the button. At least that's how it works when I test it.

Each copy must be in the same proportion of distance between the first and second copy.
A copy of txtmain must appear between each copy of rows to distinguish the end of the period.
That's up to you to figure out. You must adjust the Sh.IncrementTop value until it produces a result that you are happy with.
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,019
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I am not sure what has happened. You say that if I run the code once, there will be one copy but if I do so, it will not make any copies. Does it matter that it is a shape and not an active x control?

txtmain is a regular rectangle and I have ensured the name of it is txtmain.

Not sure if this would have anything to do with it but when I try and record a macro and move the shape around, this is the code I get
VBA Code:
'
    ActiveSheet.Shapes.Range(Array("txtmain")).Select
    Selection.Copy
    Range("D37").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=9
    Selection.ShapeRange.IncrementLeft -212.25
    Selection.ShapeRange.IncrementTop 22.5
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,019
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

I am not sure what has happened. You say that if I run the code once, there will be one copy but if I do so, it will not make any copies. Does it matter that it is a shape and not an active x control?

txtmain is a regular rectangle and I have ensured the name of it is txtmain.

Not sure if this would help but when I try and record a macro and move the shape around, this is the code I get
VBA Code:
'
    ActiveSheet.Shapes.Range(Array("txtmain")).Select
    Selection.Copy
    Range("D37").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=9
    Selection.ShapeRange.IncrementLeft -212.25
    Selection.ShapeRange.IncrementTop 22.5
 

rlv01

Well-known Member
Joined
May 16, 2017
Messages
771
I am not sure what has happened. You say that if I run the code once, there will be one copy but if I do so, it will not make any copies. Does it matter that it is a shape and not an active x control?

txtmain is a regular rectangle and I have ensured the name of it is txtmain.

Not sure if this would have anything to do with it but when I try and record a macro and move the shape around, this is the code I get
VBA Code:
'
    ActiveSheet.Shapes.Range(Array("txtmain")).Select
    Selection.Copy
    Range("D37").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=9
    Selection.ShapeRange.IncrementLeft -212.25
    Selection.ShapeRange.IncrementTop 22.5

I'm confused. What does this code have to do with the code that I posted?
 

rlv01

Well-known Member
Joined
May 16, 2017
Messages
771
You should try running this code:
VBA Code:
'This code assumes:
'1. You have a sheet in this workbook named "ACA_Quoting"
'2. On that sheet are five activeX command buttons: "cmdAddRatio", "cmdCustomSign", "cmdGsign", "cmdNoSign", "cmdSaveToPdf"
'3. Also on that sheet is one activeX text box "txtMain"

Sub ShapeMoveTest()
    Dim Total As Range
    Dim WS As Worksheet
    Dim Sh As Shape, NewShape As Shape
    Dim TTop As Long
    Dim TLeft As Long
    Dim txtMainExists As Boolean

    Set WS = ThisWorkbook.Worksheets("ACA_Quoting")

    ''' Range copy code is commented in order to focus on the shapes.
    '
    '    With WS
    '        '.Range("29:31").EntireRow.Insert
    '        '.Rows(29).Insert Shift:=xlShiftDown 'Inserts a row below the current table to create a buffer zone between the 2 tables.
    '
    '        .Range("F29:H32").Copy .Range("F51")
    '        .Range("A8:I28").Copy .Range("A38")           'Pastes a copy of the table below current table between the bottom of the table and the totals
    '        '.Range("F30:H32").Offset(2, 0).Select 'This is the range of the totals that need to be moved down so the additional table can be pasted in
    '        '.Range("C7").Insert Shift:=xlDown
    '    End With

    For Each Sh In WS.Shapes
        Debug.Print Sh.Type
        Select Case Sh.Name
        Case "cmdAddRatio", "cmdCustomSign", "cmdGsign", "cmdNoSign", "cmdSaveToPdf"
            Sh.IncrementTop 50                        'reduce increment for test purposes 505
        Case "txtMain"                                'name your first textbox, the one you want to move,  to something unique. I used "txtMain"
            txtMainExists = True
            TTop = Sh.Top                             'record position
            TLeft = Sh.Left
            Sh.IncrementTop 50                        'reduce increment for test purposes 505505
            Sh.Copy                                   'make a copy
            WS.Paste
            Set NewShape = WS.Shapes(WS.Shapes.Count)    'pasted textbox is the last shape
            With NewShape
                .Top = TTop                           'move the copy to the previous position of txtMain
                .Left = TLeft
                .OLEFormat.Object.Object.Text = .Name & "    (a copy of txtMain)"
            End With
        End Select
    Next Sh
    If Not txtMainExists Then
        MsgBox "txtMain is missing!", vbCritical
    End If
End Sub

Here are my results. Yours should be similar.

ShapeMove.png
 

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,019
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Thanks for that, now the shape part is working properly.

I think the problem might have been that my shape was not an active x text box. I inserted it by selecting the insert menu and picked shapes.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,632
Messages
5,597,287
Members
414,134
Latest member
Tiyas44

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top