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

Вход

Регистрация

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

 

= Мир MS Excel/Макрос добавляет один объект, вместо нескольких. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос добавляет один объект, вместо нескольких. (Макросы/Sub)
Макрос добавляет один объект, вместо нескольких.
Lizard Дата: Воскресенье, 16.08.2020, 06:48 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 60
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Доброго времени форумчане.

На листе есть маленькие кружки под названием "Приемный узел".
Макросом на эти приемные узлы добавляются - группы фигур по образцу (образцы размещены на правой стороне листа).
Каждый образец имеет свое название и соотношение "приемных узлов" и групп-образцов указано в таблице AI10:AJ22
Однако в этой таблице на один приемный узел - может приходится несколько групп-образцов, а срабатывает добавление только одного образца, а не нескольких.

Как вы считаете - что поправить в макросе, чтобы он мог добавить несколько различных объектов - на один и тот же "приемный узел", указанный в таблице AI10:AJ22 ?
(Сейчас он может добавить только одну группу - на один приемный узел.)
[vba]
Код

Option Explicit

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

Dim ss As Shapes
Dim s As Shape
Dim s2 As Shape
Dim sh As Shape
Dim sh2 As Shape
Dim redPoint As Shape
Dim r As Range, r2 As Range
Dim sourse As String
Dim destX As Single, destY As Single
Dim targetX As Single, targetY As Single
Dim sr As Shapes
Dim ids As Variant

Public Sub CloneAndMode2()
    Application.ScreenUpdating = False
    On Error Resume Next
    Set r = [AI10:AI16]: Set r2 = [AJ10:AJ16]
    Set ss = ActiveSheet.Shapes
    ReDim ids(1 To 1)
    For Each s In ss
        If s.Type = msoGroup Then
            For Each s2 In s.GroupItems
                If s2.Name Like "Приемный узел*" Then
                   Call Ungroup2(s)
                   Call moveshape2(s2)
                   Call Group2
                End If
            Next
        Else
            If s.Name Like "Приемный узел*" Then
                Call moveshape2(s)
            End If
        End If
    Next
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Private Sub moveshape2(ByRef sh As Shape)
    sourse = Cells(r.Find(sh.Name).Row, r.Find(sh.Name).Column + 1).Value
    ActiveSheet.Shapes(sourse).Copy
    Sleep 200
    ActiveSheet.Paste
    Set sh2 = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    sh2.Name = sh2.Name & "_" & (Time * 1000)
    Set redPoint = sh2.GroupItems("redPoint")
    targetX = sh2.Left + 0.5 * sh.Width
    targetY = sh2.Top + 0.5 * sh.Height
    destX = sh.Left - (redPoint.Left + 0.5 * redPoint.Width) + targetX
    destY = sh.Top - (redPoint.Top + 0.5 * redPoint.Height) + targetY
    sh2.Top = destY
    sh2.Left = destX
End Sub

Private Sub Ungroup2(ByRef sh As Shape)
    Dim sh3 As Shape
    Dim n As Long
    n = 1
    For Each sh3 In sh.GroupItems
        ReDim Preserve ids(1 To n)
        ids(n) = sh3.ID
        n = n + 1
    Next
    sh.Ungroup
End Sub

Private Sub Group2()
    Dim i As Long
    Dim ssh As Shape
    For i = 1 To UBound(ids)
        For Each ssh In ActiveSheet.Shapes
            If ssh.ID = ids(i) Then
                If i = 1 Then
                    ssh.Select
                Else
                    ssh.Select Replace:=False
                End If
            End If
        Next
    Next
    ActiveWindow.Selection.ShapeRange.Group
    Erase ids
End Sub

[/vba]
К сообщению приложен файл: 5842108.xls(81.5 Kb)
 
Ответить
СообщениеДоброго времени форумчане.

На листе есть маленькие кружки под названием "Приемный узел".
Макросом на эти приемные узлы добавляются - группы фигур по образцу (образцы размещены на правой стороне листа).
Каждый образец имеет свое название и соотношение "приемных узлов" и групп-образцов указано в таблице AI10:AJ22
Однако в этой таблице на один приемный узел - может приходится несколько групп-образцов, а срабатывает добавление только одного образца, а не нескольких.

Как вы считаете - что поправить в макросе, чтобы он мог добавить несколько различных объектов - на один и тот же "приемный узел", указанный в таблице AI10:AJ22 ?
(Сейчас он может добавить только одну группу - на один приемный узел.)
[vba]
Код

Option Explicit

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

Dim ss As Shapes
Dim s As Shape
Dim s2 As Shape
Dim sh As Shape
Dim sh2 As Shape
Dim redPoint As Shape
Dim r As Range, r2 As Range
Dim sourse As String
Dim destX As Single, destY As Single
Dim targetX As Single, targetY As Single
Dim sr As Shapes
Dim ids As Variant

Public Sub CloneAndMode2()
    Application.ScreenUpdating = False
    On Error Resume Next
    Set r = [AI10:AI16]: Set r2 = [AJ10:AJ16]
    Set ss = ActiveSheet.Shapes
    ReDim ids(1 To 1)
    For Each s In ss
        If s.Type = msoGroup Then
            For Each s2 In s.GroupItems
                If s2.Name Like "Приемный узел*" Then
                   Call Ungroup2(s)
                   Call moveshape2(s2)
                   Call Group2
                End If
            Next
        Else
            If s.Name Like "Приемный узел*" Then
                Call moveshape2(s)
            End If
        End If
    Next
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Private Sub moveshape2(ByRef sh As Shape)
    sourse = Cells(r.Find(sh.Name).Row, r.Find(sh.Name).Column + 1).Value
    ActiveSheet.Shapes(sourse).Copy
    Sleep 200
    ActiveSheet.Paste
    Set sh2 = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    sh2.Name = sh2.Name & "_" & (Time * 1000)
    Set redPoint = sh2.GroupItems("redPoint")
    targetX = sh2.Left + 0.5 * sh.Width
    targetY = sh2.Top + 0.5 * sh.Height
    destX = sh.Left - (redPoint.Left + 0.5 * redPoint.Width) + targetX
    destY = sh.Top - (redPoint.Top + 0.5 * redPoint.Height) + targetY
    sh2.Top = destY
    sh2.Left = destX
End Sub

Private Sub Ungroup2(ByRef sh As Shape)
    Dim sh3 As Shape
    Dim n As Long
    n = 1
    For Each sh3 In sh.GroupItems
        ReDim Preserve ids(1 To n)
        ids(n) = sh3.ID
        n = n + 1
    Next
    sh.Ungroup
End Sub

Private Sub Group2()
    Dim i As Long
    Dim ssh As Shape
    For i = 1 To UBound(ids)
        For Each ssh In ActiveSheet.Shapes
            If ssh.ID = ids(i) Then
                If i = 1 Then
                    ssh.Select
                Else
                    ssh.Select Replace:=False
                End If
            End If
        Next
    Next
    ActiveWindow.Selection.ShapeRange.Group
    Erase ids
End Sub

[/vba]

Автор - Lizard
Дата добавления - 16.08.2020 в 06:48
Pelena Дата: Воскресенье, 16.08.2020, 09:12 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 16638
Репутация: 3597 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Здравствуйте.
Сильно в алгоритм не вдавалась, попробуйте так
К сообщению приложен файл: 5842108-1-.xls(78.0 Kb)


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Сильно в алгоритм не вдавалась, попробуйте так

Автор - Pelena
Дата добавления - 16.08.2020 в 09:12
Lizard Дата: Воскресенье, 16.08.2020, 10:48 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 60
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Pelena, спасибо - заработало.
 
Ответить
СообщениеPelena, спасибо - заработало.

Автор - Lizard
Дата добавления - 16.08.2020 в 10:48
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос добавляет один объект, вместо нескольких. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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