CODEWITHSUNDEEP
vbaexcel
Andrei Ion
Andrei Ion

Reputation: 1827

How to draw rectangles and assign macros to them from VBA?

Here's what I want to do and I really don't know how to do it or if it is possible. I have one column where some values are generated. Let's say the column number is 10. What I want to do... if the value of a cell in that column is > 1 I want to draw a rectangle (in the next cell or close to that cell) (column 11 same row) with a macro assigned to it. The macro will insert another row right after that one where the cell is and where the rectangle will be drawn so I have to get somehow the position of the rectangle. Any ideas? Thanks a lot!

Upvotes: 2

Views: 13741

Answers (4)

Alvin567
Alvin567

Reputation: 335

Please see my code if helps. Basically it draws a rectangle at the top of the pages so that you can use it as you wish to be.

Sub Red_Box()
    Dim BBB         As Shape
    Set BBB = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, _
        Left:=50, Top:=50, Width:=50, Height:=50, _
        Anchor:=Selection.Range)
    With BBB
        .PictureFormat.TransparentBackground = True
        .Line.ForeColor.RGB = RGB(255, 0, 0)
        .WrapFormat.Type = wdWrapFront
        .ZOrder (msoBringForward)
        .Select
    End With
End Sub

Upvotes: 0

Reafidy
Reafidy

Reputation: 8441

An alternative to shapes would be to use a border and the double click event.

Add the code to your worksheet module and change a cell value in column 10. Then double click the cell containing the border.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   If Not Intersect(Target, Columns(11)) Is Nothing And Target.Count = 1 Then
        If Target.Offset(, -1).Value > 1 And Target.Borders.Count > 0 Then
          Target.Offset(1).EntireRow.Insert xlDown, False
          Cancel = True
        End If
   End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(10)) Is Nothing And Target.Count = 1 Then
        If Target.Value > 1 And IsNumeric(Target) Then
            Target.Offset(, 1).BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
            Else
            Target.Offset(, 1).Borders.LineStyle = xlNone
        End If
    End If
End Sub

If you really want to use a shape then try something like below.

In worksheet module:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(10)) Is Nothing And Target.Count = 1 Then
        If Target.Value > 1 And IsNumeric(Target) Then
            AddShape Target.Offset(0, 1)
            Else
            DeleteShape Target.Offset(0, 1)
        End If
    End If
End Sub

In a normal module:

Sub AddShape(rCell As Range)
    '// Check if shape already exists
    Dim shLoop As Shape
    For Each shLoop In rCell.Parent.Shapes
        If shLoop.Type = msoShapeRectangle And shLoop.TopLeftCell = rCell Then                
            Exit Sub
        End If
    Next shLoop

    With rCell.Parent.Shapes.AddShape(msoShapeRectangle, rCell.Left, rCell.Top, rCell.Width, rCell.Height)
        .OnAction = "ShapeClick"
    End With
End Sub

Sub DeleteShape(rCell As Range)
    Dim shLoop As Shape

    For Each shLoop In rCell.Parent.Shapes
        If shLoop.Type = msoShapeRectangle And shLoop.TopLeftCell = rCell Then
            shLoop.Delete
            Exit For
        End If
    Next
End Sub

Sub ShapeClick()
    With ActiveSheet.Shapes(Application.Caller)
        ActiveSheet.Rows(.TopLeftCell.Row + 1).Insert Shift:=xlDown
    End With
End Sub

Upvotes: 2

jonsca
jonsca

Reputation: 10381

Here's an outline. InsertRows() is a UDF to insert the row

Sub FindErrors(ByVal myrange As Range)
    Dim xCell As range
    For Each xCell In myrange
        If xCell.Value >= 1 Then
            xCell.Offset(0, 1).BorderAround xlContinuous, xlThick
            xCell.Offset(0, 1) = InsertRow(range("A13:F13"))
        End If
    Next

End Sub

Pass in a range for it to operate on. Based on the other answer, I'm not sure the border coloring is what you are looking for, but you get the idea.

Upvotes: 1

Tim Williams
Tim Williams

Reputation: 166316

Sub Tester()
Dim c As Range

    For Each c In ActiveSheet.Range("A2:A30")
        If c.Value > 1 Then
            AddShape c.Offset(0, 1)
        End If
    Next c

End Sub


Sub AddShape(rng As Range)
    With rng.Cells(1).Parent.Shapes.AddShape(msoShapeRectangle, rng.Left, _
                                    rng.Top, rng.Width, rng.Height)
        .OnAction = "DoInsertAction"
    End With
End Sub

Sub DoInsertAction()
    Dim r As Long
    r = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
    ActiveSheet.Rows(r + 1).Insert Shift:=xlDown
End Sub

Upvotes: 5

Related Questions