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开发者_StackOverflow中文版 of the rectangle. Any ideas? Thanks a lot!

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

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

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.

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