如何从 VBA 绘制矩形并为其分配宏？

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

提问by Andrei Ion

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!

这就是我想要做的，我真的不知道该怎么做或者是否可能。我有一列，其中生成了一些值。假设列号为 10。我想要做什么...如果该列中的单元格的值 > 1 我想绘制一个矩形（在下一个单元格中或靠近该单元格）（第 11 列同一行) 并为其分配了一个宏。宏将在单元格所在的位置和将绘制矩形的位置之后插入另一行，因此我必须以某种方式获得矩形的位置。有任何想法吗？非常感谢！

回答by Tim Williams

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

回答by Reafidy

An alternative to shapeswould 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.

将代码添加到您的工作表模块并更改第 10 列中的单元格值。然后双击包含边框的单元格。

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 shapethen 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

回答by jonsca

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

这是一个大纲。 InsertRows()是用于插入行的 UDF

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.

传入一个范围以供其操作。根据另一个答案，我不确定边框着色是您要查找的内容，但您明白了。