Private Sub Draws_In_Selection_Select() ' выделить В ВЫБРАННОМ ДИАПАЗОНЕ все рисунки
Dim oDraw, rSel As Range
Set rSel = ActiveWindow.RangeSelection
For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Range(oDraw.TopLeftCell, oDraw.BottomRightCell), rSel) Is Nothing Then oDraw.Select (False)
Next
End Sub
попыталась его преобразовать:
Код
Sheets("For schedule" ;) .Select
'Delete all graphic obects
Dim oDraw, rSel As Range
[COLOR=#00FF00] Set rSel = Range("S2:Y500" ;) [/COLOR]
For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Range(oDraw.TopLeftCell, oDraw.BottomRightCell), rSel) Is Nothing Then oDraw.Select (False)
Next
Selection.Delete
а удаляет все графические объекты, в том числе и мою красивую кнопку запуска макроса, которая располагается в столбцу Q:Q
Dim oDraw, rSel As Range
Set rSel = Range("S2:Y500")
For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Range(oDraw.TopLeftCell, oDraw.BottomRightCell), rSel) Is Nothing Then oDraw.Delete
Next
Dim oDraw, rSel As Range
For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Range(oDraw.TopLeftCell, oDraw.BottomRightCell), Selection) Is Nothing Then oDraw.Delete
Next
Ну не работает в рабочем файле. Сделал пример, а в нём всё прекрасно работает. Правда, пример опять же зашкаливает за 100 кб, т.к. там картинки и объекты, от которых нужно избавиться. Но не с ActiveSheet, а с диапазона B2:P100. Покажу, что происходит на картинке. При пошаговом просмотре, вдруг открывается UDF_ка, которая работает в диапазоне А35:А54 и к этому макросу не имеет никакого отношения.
Скрытый текст
Sub UpdatePROCH()Dim oDraw As Object, rSel As Range Set rSel = Range("B2:P150") With rSel .Hyperlinks.Delete .UnMerge .RowHeight = 12 Range("S2").Copy .PasteSpecial Paste:=xlPasteFormats End With On Error Resume Next For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange If Not Intersect(Range(oDraw.TopLeftCell, oDraw.BottomRightCell), rSel) Is Nothing Then oDraw.Delete Next End Sub