如何从VBA中绘制矩形和分配macros？

这是我想要做的，我真的不知道该怎么做，或者如果可能。 我有一列中生成一些值。 假设列号为10.我想要做什么…如果该列中单元格的值大于1我想绘制一个矩形（在下一个单元格中或靠近该单元格）（第11列相同的行）与分配给它的macros。 该macros将插入另一个行之后的那个单元格和矩形将被绘制的位置，所以我必须得到矩形的位置。 有任何想法吗？ 非常感谢！

Answer 1

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 

Answer 2

形状的另一种select是使用边框和双击事件。

将代码添加到工作表模块并更改第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 

如果你真的想使用一个形状，然后尝试下面的东西。

在工作表模块中：

 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 

在一个正常的模块中：

 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 

Answer 3

这是一个大纲。 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 

通过一个范围来操作。 基于另一个答案，我不确定边界着色是你在找什么，但你明白了。