Copy/Paste textboxes into alternate rows

**JoeVanGeaux** · 03-07-2017, 12:51 AM

In the attached sample file, I show the basic page layout where I am trying to add an empty textbox into the bottom portion of a cell in every other line which would then be indexed based on a cell in another worksheet. I found that I can copy and Paste Special (as a GIF) for each line, but this involves manually dragging the box into position.

For only a few cells, this wouldn’t be a problem, but I have about 600 rows (1200 in all but I need to skip every other row). I searched the net and this forum’s archives but can’t find a solution to match or get close enough to my situation for me to experiment. Any suggestions?

**JoeVanGeaux** · 03-07-2017, 12:17 PM

I found the code below and messed with it a bit and messed up my worksheet. If someone knows where I can make something encouraging show up on the screen that'd be a good a start (For now, I can't even consider what I tried a "start", yet!) Thanks for any suggestions, at all.

Option Explicit

Sub AddaTextBox()
    Dim mybox
    Dim top, left, height, width, margin
    margin = 20
    With ThisWorkbook.ActiveSheet.Shapes
        left = .Item(.Count).left
        top = .Item(.Count).top + .Item(.Count - 1).height + margin
        width = .Item(.Count).width
        height = .Item(.Count).height
    Set mybox = .addtextbox(msoTextOrientationHorizontal, left, top, width, height)
    End With
End Sub

**JoeVanGeaux** · 03-07-2017, 04:55 PM

Having some success with code below. But can't get it to move to next row. (It does make many repeated inserts into same place, though.) The commented-out section works but this would mean I'd have to insert about 650 groups of code...twice, because I have a nearly identical second worksheet. I would then be able to tackle the "Selection.Formula" part afterwards.

Private Sub InsertNewLinkedTextBoxes2()
'
'
Dim c As Range
Dim rng As Range
Set rng = Selection

    For Each c In rng
        c = RowCount
        RowCount = RowCount + 1
                
    'FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To 8 Step 2 'trying to limit range for now original code:"FinalRow Step 2"
    
            ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
            Selection.Copy
            ActiveWindow.SmallScroll Down:=3
    
            Range("C5:G5").Select
            ActiveSheet.PasteSpecial Format:="Microsoft Office Drawing Object", Link:= _
                False, DisplayAsIcon:=False
            Selection.ShapeRange.IncrementTop 137.25
            Selection.Formula = "=Sheet2!G5"
            ActiveWindow.SmallScroll Down:=3
            
        Next i
    Next
    
'    Range("C7:G7").Select
'    ActiveSheet.PasteSpecial Format:="Microsoft Office Drawing Object", Link:= _
'        False, DisplayAsIcon:=False
'    Selection.ShapeRange.IncrementTop 137.25
'    Selection.Formula = "=Sheet2!G7"
'    ActiveWindow.SmallScroll Down:=3
'
'    Range("C9:G9").Select
'    ActiveSheet.PasteSpecial Format:="Microsoft Office Drawing Object", Link:= _
'        False, DisplayAsIcon:=False
'    Selection.ShapeRange.IncrementTop 137.25
'    Selection.Formula = "=Sheet2!G9"
'    Range("C9:G9").Select
    
End Sub