Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Управление группами фигур - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Управление группами фигур (Макросы/Sub)
Управление группами фигур
skif40 Дата: Вторник, 26.06.2018, 23:47 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Прошу корифеев помочь с написанием кода для вызова нескольких одинаковых фигур (цилиндров) и дальнейнего обьединения их в группу, название которой каждый раз вводиться вручную в ячейку D1. Надо вызывать несколько групп фигур, которые могут отличаться количеством фигур ( цилиндров) в группе. Файл прилагается. Размеры каждой фигуры задаются в ячейках A1, B1 , C1 соответственно.
У меня получилось только вызывать первую партию фигур, которые не получается программно сгруппировать и присвоить имя из D1, чтобы сдвинуть их на другое место и повернуть. Вызов следующей группы фигур также не получается. С ув. Василий
К сообщению приложен файл: 4546740.xlsm (28.8 Kb)
 
Ответить
СообщениеПрошу корифеев помочь с написанием кода для вызова нескольких одинаковых фигур (цилиндров) и дальнейнего обьединения их в группу, название которой каждый раз вводиться вручную в ячейку D1. Надо вызывать несколько групп фигур, которые могут отличаться количеством фигур ( цилиндров) в группе. Файл прилагается. Размеры каждой фигуры задаются в ячейках A1, B1 , C1 соответственно.
У меня получилось только вызывать первую партию фигур, которые не получается программно сгруппировать и присвоить имя из D1, чтобы сдвинуть их на другое место и повернуть. Вызов следующей группы фигур также не получается. С ув. Василий

Автор - skif40
Дата добавления - 26.06.2018 в 23:47
sboy Дата: Среда, 27.06.2018, 10:00 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
для объединения в группу автофигур нужно собрать их имена в массив.
Т.к. у Вас много Case'ов в коде вникать особо не стал, сделал пример для 2 фигур
[vba]
Код

'...................
ReDim shp_arr(1 To Q) ' объявляем массив по количеству фигур
  Select Case Q
Case Is < 3
         For i = 1 To Q
                Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L, Top, d, lg)
                shp_arr(i) = shp.Name 'записываем массив
            L = L + d
         Next
'.......................
  Set gr_shp = ActiveSheet.Shapes.Range(shp_arr) 'вставленные фигуры
  Set gr_shp = gr_shp.Group 'группируем
  gr_shp.Name = [d1].Value 'имя
[/vba]

Обращаю внимание, что код в файле работает ТОЛЬКО для 2 фигур (для примера)
К сообщению приложен файл: 2173348.xlsm (31.1 Kb)


Яндекс: 410016850021169
 
Ответить
СообщениеДобрый день.
для объединения в группу автофигур нужно собрать их имена в массив.
Т.к. у Вас много Case'ов в коде вникать особо не стал, сделал пример для 2 фигур
[vba]
Код

'...................
ReDim shp_arr(1 To Q) ' объявляем массив по количеству фигур
  Select Case Q
Case Is < 3
         For i = 1 To Q
                Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L, Top, d, lg)
                shp_arr(i) = shp.Name 'записываем массив
            L = L + d
         Next
'.......................
  Set gr_shp = ActiveSheet.Shapes.Range(shp_arr) 'вставленные фигуры
  Set gr_shp = gr_shp.Group 'группируем
  gr_shp.Name = [d1].Value 'имя
[/vba]

Обращаю внимание, что код в файле работает ТОЛЬКО для 2 фигур (для примера)

Автор - sboy
Дата добавления - 27.06.2018 в 10:00
skif40 Дата: Среда, 27.06.2018, 12:32 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Спасибо за подсказку, получил, ковыряюсь.
Пытаюсь избавться от Case's и адаптировать макрос , чтобы цилиндры укладывались в пирамиду в два/три / четыре ряда в зависимости от количества цилиндров.
С ув. Василий
 
Ответить
СообщениеСпасибо за подсказку, получил, ковыряюсь.
Пытаюсь избавться от Case's и адаптировать макрос , чтобы цилиндры укладывались в пирамиду в два/три / четыре ряда в зависимости от количества цилиндров.
С ув. Василий

Автор - skif40
Дата добавления - 27.06.2018 в 12:32
sboy Дата: Среда, 27.06.2018, 14:01 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Пытаюсь избавться от Case's

Появилась идея использовать расчетную табличку для определения количество рядов.
А сколько может быть максимум штук? так чисто теоритически


Яндекс: 410016850021169
 
Ответить
Сообщение
Пытаюсь избавться от Case's

Появилась идея использовать расчетную табличку для определения количество рядов.
А сколько может быть максимум штук? так чисто теоритически

Автор - sboy
Дата добавления - 27.06.2018 в 14:01
skif40 Дата: Среда, 27.06.2018, 16:36 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
sboy,
Обычно не превышает 15.
Василий
 
Ответить
Сообщениеsboy,
Обычно не превышает 15.
Василий

Автор - skif40
Дата добавления - 27.06.2018 в 16:36
skif40 Дата: Среда, 27.06.2018, 16:39 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
В первом примере при А1=15 вырисовывается, то что надо получить. Но не получалось прикрутить макрос.
С ув. Василий
 
Ответить
СообщениеВ первом примере при А1=15 вырисовывается, то что надо получить. Но не получалось прикрутить макрос.
С ув. Василий

Автор - skif40
Дата добавления - 27.06.2018 в 16:39
Roman777 Дата: Среда, 27.06.2018, 16:44 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
skif40, примерно так можно (исправлено):
[vba]
Код
Private Sub CommandButton1_Click()
    Dim i As Integer, Q As Byte
    Dim Left As Integer
    Dim d As Integer
    Dim Top As Integer
    Dim L As Integer
    Dim k As Long, ShapeNames() As String
    Dim shp As Shape
    Dim f As Long, start As Long, line As Long, displacement As Long
    Dim L_ As Double, L_2 As Double, flg As Boolean
    Q = Sheets("Plan").Range("a1").Value
    d = Sheets("Plan").Range("B1").Value
    lg = Sheets("Plan").Range("C1").Value
    Left = 25
    Top = 50
    L = Left
    
    start = -1
    line = 1
    displacement = 0
    L_ = L
    L_2 = L_
    ReDim ShapeNames(Q - 1)
    k = k + 1
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L_, Top * line, d, lg)
    ShapeNames(k - 1) = shp.Name
    Do
        If (f > start) Then
            displacement = displacement + 1
            L_2 = L_2 + d
            L_ = L_2
            line = 1
            start = (L_ - L) / d
            f = 0
            ff = 0
        Else
            line = line + 1
            L_ = L_ - d / 2
            displacement = 1
        End If
        f = f + 1
        k = k + 1
        Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L_, Top * line, d, lg)
        ShapeNames(k - 1) = shp.Name
    Loop While k < Q

    Set r = ActiveSheet.Shapes.Range(ShapeNames).Group
    r.Name = Cells(1, 4)
End Sub
[/vba]


Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Среда, 27.06.2018, 16:49
 
Ответить
Сообщениеskif40, примерно так можно (исправлено):
[vba]
Код
Private Sub CommandButton1_Click()
    Dim i As Integer, Q As Byte
    Dim Left As Integer
    Dim d As Integer
    Dim Top As Integer
    Dim L As Integer
    Dim k As Long, ShapeNames() As String
    Dim shp As Shape
    Dim f As Long, start As Long, line As Long, displacement As Long
    Dim L_ As Double, L_2 As Double, flg As Boolean
    Q = Sheets("Plan").Range("a1").Value
    d = Sheets("Plan").Range("B1").Value
    lg = Sheets("Plan").Range("C1").Value
    Left = 25
    Top = 50
    L = Left
    
    start = -1
    line = 1
    displacement = 0
    L_ = L
    L_2 = L_
    ReDim ShapeNames(Q - 1)
    k = k + 1
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L_, Top * line, d, lg)
    ShapeNames(k - 1) = shp.Name
    Do
        If (f > start) Then
            displacement = displacement + 1
            L_2 = L_2 + d
            L_ = L_2
            line = 1
            start = (L_ - L) / d
            f = 0
            ff = 0
        Else
            line = line + 1
            L_ = L_ - d / 2
            displacement = 1
        End If
        f = f + 1
        k = k + 1
        Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L_, Top * line, d, lg)
        ShapeNames(k - 1) = shp.Name
    Loop While k < Q

    Set r = ActiveSheet.Shapes.Range(ShapeNames).Group
    r.Name = Cells(1, 4)
End Sub
[/vba]

Автор - Roman777
Дата добавления - 27.06.2018 в 16:44
sboy Дата: Среда, 27.06.2018, 17:44 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
У меня вот так вот получилось на бесконечную пирамиду
[vba]
Код
Private Sub CommandButton1_Click()
    Dim shp As Shape
    Dim shp_arr()
Q = Sheets("Plan").Range("a1").Value
d = Sheets("Plan").Range("B1").Value
lg = Sheets("Plan").Range("C1").Value
Left_ = 25
Top_ = 50
'////////Вычисление рядов/////////
    x = Q
    y = 1
    j = 1
    Dim rd()
    ReDim rd(1 To j)
    Do Until y + i > x
        y = y + i
        i = i + 1
    Loop
    rd(j) = i
    y = x - i
    If y > 0 Then
        Do Until y = 0
            j = j + 1
            ReDim Preserve rd(1 To j)
            i = WorksheetFunction.Min(y, i - 1)
            rd(j) = i
            y = y - i
        Loop
    End If
'////////////////////////////////////////
    If j > 1 Then
        ReDim shp_arr(1 To Q) ' объявляем массив по количеству фигур
        p = 1
    End If
    For zz = 1 To j
        L = Left_ + ((zz - 1) * (d / 2))
        T = Top_ + ((zz - 1) * (d / 4))
        For zzz = 1 To rd(zz)
            Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L, T, d, lg)
             L = L + d
             If p Then
                shp_arr(p) = shp.Name
                p = p + 1
             End If
        Next zzz
    Next zz
    If p Then
        Set gr_shp = ActiveSheet.Shapes.Range(shp_arr) 'вставленные фигуры
        Set gr_shp = gr_shp.Group 'группируем
        Else: Set gr_shp = ActiveSheet.Shapes.Range(shp.Name)
    End If
    gr_shp.Name = [d1].Value 'имя
End Sub
[/vba]
К сообщению приложен файл: 4835178.xlsm (32.9 Kb)


Яндекс: 410016850021169
 
Ответить
СообщениеУ меня вот так вот получилось на бесконечную пирамиду
[vba]
Код
Private Sub CommandButton1_Click()
    Dim shp As Shape
    Dim shp_arr()
Q = Sheets("Plan").Range("a1").Value
d = Sheets("Plan").Range("B1").Value
lg = Sheets("Plan").Range("C1").Value
Left_ = 25
Top_ = 50
'////////Вычисление рядов/////////
    x = Q
    y = 1
    j = 1
    Dim rd()
    ReDim rd(1 To j)
    Do Until y + i > x
        y = y + i
        i = i + 1
    Loop
    rd(j) = i
    y = x - i
    If y > 0 Then
        Do Until y = 0
            j = j + 1
            ReDim Preserve rd(1 To j)
            i = WorksheetFunction.Min(y, i - 1)
            rd(j) = i
            y = y - i
        Loop
    End If
'////////////////////////////////////////
    If j > 1 Then
        ReDim shp_arr(1 To Q) ' объявляем массив по количеству фигур
        p = 1
    End If
    For zz = 1 To j
        L = Left_ + ((zz - 1) * (d / 2))
        T = Top_ + ((zz - 1) * (d / 4))
        For zzz = 1 To rd(zz)
            Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L, T, d, lg)
             L = L + d
             If p Then
                shp_arr(p) = shp.Name
                p = p + 1
             End If
        Next zzz
    Next zz
    If p Then
        Set gr_shp = ActiveSheet.Shapes.Range(shp_arr) 'вставленные фигуры
        Set gr_shp = gr_shp.Group 'группируем
        Else: Set gr_shp = ActiveSheet.Shapes.Range(shp.Name)
    End If
    gr_shp.Name = [d1].Value 'имя
End Sub
[/vba]

Автор - sboy
Дата добавления - 27.06.2018 в 17:44
skif40 Дата: Среда, 27.06.2018, 17:45 | Сообщение № 9
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Да, это почти то, что надо. Только сдвиг рядов великоват. (РАССТОЯНИЕ МЕЖДУ ПЕРВЫМ И ПОСЛЕДУЮЩИМ РЯДАМИ).Как можно уменьшить смещение?
С ув. Василий
 
Ответить
СообщениеДа, это почти то, что надо. Только сдвиг рядов великоват. (РАССТОЯНИЕ МЕЖДУ ПЕРВЫМ И ПОСЛЕДУЮЩИМ РЯДАМИ).Как можно уменьшить смещение?
С ув. Василий

Автор - skif40
Дата добавления - 27.06.2018 в 17:45
skif40 Дата: Среда, 27.06.2018, 17:55 | Сообщение № 10
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
sboy,
Это то, что надо. Большое спасибо Вам и Roman777 за содействие.

С ув.Василий
 
Ответить
Сообщениеsboy,
Это то, что надо. Большое спасибо Вам и Roman777 за содействие.

С ув.Василий

Автор - skif40
Дата добавления - 27.06.2018 в 17:55
Roman777 Дата: Четверг, 28.06.2018, 09:30 | Сообщение № 11
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
skif40, я почему-то подумал, что первоначальный макрос Вы сами делали...
чтобы подправить
РАССТОЯНИЕ МЕЖДУ ПЕРВЫМ И ПОСЛЕДУЮЩИМ РЯДАМИ

достаточно поменять в выражение [vba]
Код
Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L_, Top * line, d, lg)
[/vba]
на:
[vba]
Код
Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L_, Top+ Top_ * (line-1), d, lg)
[/vba]
где Top_ - будет величина сдвига...


Много чего не знаю!!!!
 
Ответить
Сообщениеskif40, я почему-то подумал, что первоначальный макрос Вы сами делали...
чтобы подправить
РАССТОЯНИЕ МЕЖДУ ПЕРВЫМ И ПОСЛЕДУЮЩИМ РЯДАМИ

достаточно поменять в выражение [vba]
Код
Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L_, Top * line, d, lg)
[/vba]
на:
[vba]
Код
Set shp = ActiveSheet.Shapes.AddShape(msoShapeCan, L_, Top+ Top_ * (line-1), d, lg)
[/vba]
где Top_ - будет величина сдвига...

Автор - Roman777
Дата добавления - 28.06.2018 в 09:30
skif40 Дата: Четверг, 28.06.2018, 15:15 | Сообщение № 12
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Roman777,
Да, макрос пытался написать сам. Но уровень не тот, поэтому получилось не совсем красиво, но работало.
Еще раз благодарю за код. Пробую прикрутить оба варианта к своей задаче.
С ув. Василий
 
Ответить
СообщениеRoman777,
Да, макрос пытался написать сам. Но уровень не тот, поэтому получилось не совсем красиво, но работало.
Еще раз благодарю за код. Пробую прикрутить оба варианта к своей задаче.
С ув. Василий

Автор - skif40
Дата добавления - 28.06.2018 в 15:15
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Управление группами фигур (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!