如何从VBA绘制矩形并将宏分配给它们？

Question

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

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

这是一个大纲。 InsertRows()是插入该行

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 

通行证的范围内为它在操作UDF。基于另一个答案，我不确定边界着色是你在找什么，但你明白了。

Answer 3

到形状另一种方法是使用一个边框和双击事件。

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