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

[dpaton05]

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?

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

 

[rlv01]

Perhaps something like this.

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]

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

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]

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]

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]

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

'
    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]

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

'
    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]

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

'
    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]

You should try running this 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.

 

[dpaton05]

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.