Страницы: 1
RSS
Как выделить фигуры - по конкретному признаку
 
Приветствую.
Такой вопрос у меня возник.

Как выделить фигуры - по конкретному признаку - это фигуры-прямоугольники, у которых бесцветный контур и нет заливки ?
И особенность в том, что данные фигуры - входят в единую группу.
 
Добрый день!
Выделить ручками или с помощью макроса?
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Михаил Лебедев, макроса.
 
Выделили, и что? Зачем выделять? Какова цель?
 
Юрий М, чтобы подвинуть их всех разом.
А то при изменении масштаба этой группы - надписи немного съезжают.
 
Скажите - как макросом выделить фигуры - по конкретному признаку - это фигуры-прямоугольники, у которых бесцветный контур и нет заливки ?
И особенность в том, что данные фигуры - входят в единую группу.

(Это нужно чтобы подвинуть разом эти выделенные фигуры - когда они неровно располагаются в отношении других фигур.)  
 
Цитата
Lizard2 написал:
подвинуть разом
Код
Sub Макрос1()
    Const СдвигВлево = -0.75
    ActiveSheet.Shapes("Group 10").IncrementLeft СдвигВлево
End Sub
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Цитата
Lizard2 написал:
чтобы подвинуть их всех разом.
Для этого необязательно фигуры выделять.
 
Михаил Лебедев, так это надписи надо двигать в отношении остальных фигур в группе, а не всю группу разом.
И потом - двигать надо мне лично, поскольку только я могу определить в каком направлении они съехали чтобы их поправить. А макросу нужно только их выделить, а не сдвигать.
 
Цитата
Lizard2 написал:
так это надписи надо двигать в отношении остальных фигур в группе, а не всю группу разом
Код
Sub Макрос2()
    Dim shp
    Dim arr()
    Dim arrRectangle()
    Dim str As String
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoGroup Then
            i = shp.GroupItems.Count
            ReDim arr(1 To i): i = 1
            For Each shpChild In shp.GroupItems
                arr(i) = shpChild.Name
                i = i + 1
                If shpChild.Name Like "*Rectangle*" Then L = L + 1
            Next
            ReDim arrRectangle(1 To L): L = 1
            For i = LBound(arr) To UBound(arr)
                If arr(i) Like "*Rectangle*" Then
                    arrRectangle(L) = arr(i)
                    L = L + 1
                End If
            Next
            ActiveSheet.Shapes.Range(arrRectangle).Select
        End If
    Next
End Sub
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Михаил Лебедев, Спасибо !
Страницы: 1
Наверх