Как рисовать прямоугольники и назначать им макросы из 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

Альтернативой фигурам будет использование границы и события двойного щелчка.

Добавьте код в модуль рабочего листа и измените значение ячейки в столбце 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

Передайте диапазон для работы. Основываясь на другом ответе, я не уверен, что вам нужна окраска границ, но вы поняли.