Прошу корифеев помочь с написанием кода для вызова нескольких одинаковых фигур (цилиндров) и дальнейнего обьединения их в группу, название которой каждый раз вводиться вручную в ячейку D1. Надо вызывать несколько групп фигур, которые могут отличаться количеством фигур ( цилиндров) в группе. Файл прилагается. Размеры каждой фигуры задаются в ячейках A1, B1 , C1 соответственно. У меня получилось только вызывать первую партию фигур, которые не получается программно сгруппировать и присвоить имя из D1, чтобы сдвинуть их на другое место и повернуть. Вызов следующей группы фигур также не получается. С ув. Василий
Прошу корифеев помочь с написанием кода для вызова нескольких одинаковых фигур (цилиндров) и дальнейнего обьединения их в группу, название которой каждый раз вводиться вручную в ячейку D1. Надо вызывать несколько групп фигур, которые могут отличаться количеством фигур ( цилиндров) в группе. Файл прилагается. Размеры каждой фигуры задаются в ячейках A1, B1 , C1 соответственно. У меня получилось только вызывать первую партию фигур, которые не получается программно сгруппировать и присвоить имя из D1, чтобы сдвинуть их на другое место и повернуть. Вызов следующей группы фигур также не получается. С ув. Василийskif40
Добрый день. для объединения в группу автофигур нужно собрать их имена в массив. Т.к. у Вас много 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 фигур (для примера)
Добрый день. для объединения в группу автофигур нужно собрать их имена в массив. Т.к. у Вас много 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
Спасибо за подсказку, получил, ковыряюсь. Пытаюсь избавться от Case's и адаптировать макрос , чтобы цилиндры укладывались в пирамиду в два/три / четыре ряда в зависимости от количества цилиндров. С ув. Василий
Спасибо за подсказку, получил, ковыряюсь. Пытаюсь избавться от Case's и адаптировать макрос , чтобы цилиндры укладывались в пирамиду в два/три / четыре ряда в зависимости от количества цилиндров. С ув. Василийskif40
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]
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]
Код
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]
У меня вот так вот получилось на бесконечную пирамиду [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
Да, это почти то, что надо. Только сдвиг рядов великоват. (РАССТОЯНИЕ МЕЖДУ ПЕРВЫМ И ПОСЛЕДУЮЩИМ РЯДАМИ).Как можно уменьшить смещение? С ув. Василий
Да, это почти то, что надо. Только сдвиг рядов великоват. (РАССТОЯНИЕ МЕЖДУ ПЕРВЫМ И ПОСЛЕДУЮЩИМ РЯДАМИ).Как можно уменьшить смещение? С ув. Василийskif40
Roman777, Да, макрос пытался написать сам. Но уровень не тот, поэтому получилось не совсем красиво, но работало. Еще раз благодарю за код. Пробую прикрутить оба варианта к своей задаче. С ув. Василий
Roman777, Да, макрос пытался написать сам. Но уровень не тот, поэтому получилось не совсем красиво, но работало. Еще раз благодарю за код. Пробую прикрутить оба варианта к своей задаче. С ув. Василийskif40