use button to add and offset a shape to the right of a current cell

Question

In my vba code below the goal of the code is to add shape every time to the right of the current cell. I added a gif below as well so you can see exactly what I would like to do. My code below right now causes a runtime error. I know I somehow have to use the offset command.

Sub FormButtonClick()

Set myDocument = Worksheets(1)
myDocument.Shapes.AddShape msoShapeRectangle, 50, 50, 100, 200
myDocument.Left


End Sub

Answer 1

Your solution must have several checks in order to add the shapes as you desire:

1. Only look at shapes within the ROW of the given cell
2. Determine if there are ANY shapes to the right of the given cell
3. Determine which shape is the last (rightmost) shape

There are a few details that you'll have to dig out in the example code below, but you should be able to expand the example to fit your needs.

The example makes the following assumptions:

• The shape will be the height of the current row
• The shape will be the width of its column
• (Basically, the shape will be the size of the cell!)

The code:

Option Explicit

Sub test()
    DeleteAllShapes   'for testing
    AddShape Range("B4"), ShapeText:="+"
    AddShape Range("B4"), ShapeColor:=RGB(255, 0, 0), ShapeText:="-"
    AddShape Range("B4"), ShapeColor:=RGB(0, 255, 0), ShapeText:="aaa"
    AddShape Range("B4"), ShapeColor:=RGB(0, 0, 255), ShapeText:="bbb"
    AddShape ActiveCell, ShapeText:="xxx"
End Sub

Sub DeleteAllShapes()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        shp.Delete
    Next shp
End Sub

Sub AddShape(ByRef currentCell As Range, _
             Optional ShapeColor As Long = -1, _
             Optional ShapeText As String = vbNullString)
    '--- starts with the given cell and checks to find ANY shape
    '    immediately to the right of that cell, then adds another
    '    rectangle to the right of the right-most shape
    Dim thisWS As Worksheet
    Set thisWS = currentCell.Parent
    
    Dim shp As Shape
    Dim rightmostShape As Shape
    For Each shp In thisWS.Shapes
        If ShapeInlineWith(currentCell, shp) Then
            If rightmostShape Is Nothing Then
                Set rightmostShape = shp
            Else
                If shp.Left > rightmostShape.Left Then
                    Set rightmostShape = shp
                End If
            End If
        End If
    Next shp
    
    Dim newShape As Shape
    If rightmostShape Is Nothing Then
        '--- add the first shape one column to the right,
        '    using the width of that column
        With currentCell
            Set newShape = thisWS.Shapes.AddShape(Type:=msoShapeRectangle, _
                                                  Left:=.Left + .Width, _
                                                  Top:=.Top, _
                                                  Width:=.Offset(0, 1).Width, _
                                                  Height:=.Height)
        End With
    Else
        With rightmostShape
            '--- first, find out which column we're using and
            '    get that width
            Dim col As Range
            Set col = currentCell
            Dim i As Long
            For i = 1 To thisWS.Columns.Count
                Set col = currentCell.Offset(0, i)
                If ((rightmostShape.Left >= col.Left) And _
                    (rightmostShape.Left < (col.Left + col.Width))) Then
                    Exit For
                End If
            Next i
            '--- now use the column width to add the shape
            Set newShape = thisWS.Shapes.AddShape(Type:=msoShapeRectangle, _
                                                  Left:=.Left + .Width, _
                                                  Top:=.Top, _
                                                  Width:=col.Width, _
                                                  Height:=.Height)
        End With
    End If
    
    If ShapeColor <> -1 Then
        newShape.Fill.ForeColor.RGB = ShapeColor
    End If
    
    If ShapeText <> vbNullString Then
        newShape.TextFrame.Characters.Text = ShapeText
    End If
End Sub

Private Function ShapeInlineWith(ByRef currentCell As Range, _
                                 ByRef thisShape As Shape) As Boolean
    '--- IF the given shape is in the same row and somewhere to the right
    '    of the current cell, returns TRUE
    
    '--- same row means TOP is between the cell's top and bottom
    If ((thisShape.Top >= currentCell.Top) And _
        (thisShape.Top < (currentCell.Top + currentCell.Height))) Then
        ShapeInlineWith = True
    Else
        ShapeInlineWith = False
    End If
End Function