Подскажите, очень нужно!

[longgy]

Подскажите, каким образом в макросе можно
из координатно заданной области листа Екселя
удалить линии, фигуры, тексбоксы и др. элементы.

[VictorM]

из координатно заданной области листа Екселя

по-подробнее можно?

[longgy]

На Экселевском листе рисуется макет
двери: пряоугольник, разделяющие линии (в зависимости от размера),
текстбоксы с указанием размеров и вида наполнениея двери, и нужно, чтобы при вводе новых данных старый макет стирался и в этих же координатах рисовался новый. Новый рисуется, но каждый макет накладывается на предыдущий и захламляет документ. Есть ли стандартные функции для очитски объектов только в указанной области, а то SelectAll удаляет все навесные объекты с разметками и кнопками просчета, еще пробовал вариант с ячейками, но они вырезеются со здвигом столцов - это совсем неудобно.

[SAS888]

Есть ли стандартные функции для очитски объектов

А имя у объектов есть? Удаляйте только то, что нужно.

[longgy]

Сообщение от SAS888

А имя у объектов есть?

имена то есть, только объектов каждый раз разное кол-во,
получается что единственный выход - это удалять каждый объект поименно?

[SAS888]

Ну, или все оптом, или по одному. Что не устраивает?

[IgorGO]

Насколько я понял задачу необходимо удалить перечисленные в #1обьекты, расположенные в какой-то локальной области листа?

Предлагаю вариант. Ставим курсор в любую ячейку на листе, выполняем SelectSameShapes, в результате будут ОТМЕЧЕНЫ все обьекты левая граница которых расположена в пределах одной из 3-х колонок: в колонке, где стоял курсор, либо в колонках справа или слева. После этого жмем кнопку Del - все удалены. Задача выполнена.

Что точно необходимо будет делать - так это довести до ваших потребностей код процедуры SetXY и функции OkShape.

SetXY - задает (описывает) габариты области. В моем примере габаритами области есть все, что покрыто тремя колонками.

OkShape - определяет попадает ли конкретный обьект в заданную область. В моем примере обьект попадает в область, если попадает его левый край.

То, что сделал я - достаточно только для демонстрации способа. Вариантов масса, но один напрашивается совершенно естесственно: допустим задать центр области (центр активной ячейки) и два радиуса R1, R2. Проверитять чтобы центр обьекта оказался в круге радиусом R1, а габариты не выходили за R2. Такую фигуру отмечаем.

Вобщем, вам виднее, дерзайте, успехов!

Option Explicit

Dim xb As Single, xe As Single, yb As Single, ye As Single

Sub SelectSameShapes()
Dim r As Integer, c As Integer
Dim sp1(1000), sp2(), sp
  SetXY
  c = 0: r = 0
  For Each sp In ActiveSheet.Shapes
    r = r + 1
    If OkShape(sp) Then
      c = c + 1
      sp1(c) = r
    End If
  Next
  ReDim sp2(c)
  For r = 1 To c: sp2(r) = sp1(r): Next: sp2(0) = sp2(1)
  ActiveSheet.Shapes.Range(sp2).Select
End Sub

Function OkShape(shp) As Boolean
  OkShape = shp.Left > xb And shp.Left < xe
End Function

Sub SetXY()
Dim c As Integer
  xb = 0: yb = 0
  For c = 1 To ActiveCell.Column - 2
    xb = xb + ActiveSheet.Columns(c).Width
  Next
  xe = xb
  For c = ActiveCell.Column - 1 To ActiveCell.Column + 1
    xe = xe + ActiveSheet.Columns(c).Width
  Next
End Sub

[longgy]

Сообщение от IgorGO

Вобщем, вам виднее, дерзайте, успехов!


End Sub[/CODE]

Спасибо огромное за консультацию!

[IgorGO]

Вот вариант: отметит все обьекты, у которых расстояние от центра обьекта до центра активной ячейки не больше 50 пикселей.
В SelectSameShapes добавил проверку и сообщение, когда ничего не отмечено.

Option Explicit

Dim X As Long, Y As Long, R1 As Integer, R2 As Integer

Sub SelectSameShapes()
Dim r As Integer, c As Integer
Dim sp1(1000), sp2(), sp
  SetXY
  c = 0: r = 0
  For Each sp In ActiveSheet.Shapes
    r = r + 1
    If OkShape(sp) Then
      c = c + 1
      sp1(c) = r
    End If
  Next
  ReDim sp2(c)
  If c = 0 Then MsgBox "Not Found": Exit Sub
  For r = 1 To c: sp2(r) = sp1(r): Next: sp2(0) = sp2(1)
  ActiveSheet.Shapes.Range(sp2).Select
End Sub

Function OkShape(shp) As Boolean
  OkShape = Abs(X - shp.Left - shp.Width / 2) < R1 _
  And Abs(Y - shp.Top - shp.Height / 2) < R1
End Function

Sub SetXY()
Dim c As Integer
  X = 0
  For c = 1 To ActiveCell.Column - 1
    X = X + ActiveSheet.Columns(c).Width
  Next
  X = X + ActiveCell.Width / 2
  Y = 0
  For c = 1 To ActiveCell.Row - 1
    Y = Y + ActiveSheet.Rows(c).Height
  Next
  Y = Y + ActiveCell.Height / 2
  R1 = 50
  R2 = 150
End Sub

[longgy]

Сообщение от IgorGO

В SelectSameShapes добавил проверку и сообщение, когда ничего не отмечено.
[/CODE]

О! То что нужно! пойду воткну! Спасибо!