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

Вход

Регистрация

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

 

= Мир MS Excel/как заставить фигуру двигаться по маршруту в таблице - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » как заставить фигуру двигаться по маршруту в таблице (Макросы/Sub)
как заставить фигуру двигаться по маршруту в таблице
OlegSmirnov Дата: Понедельник, 07.08.2017, 11:57 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Здравствуйте, уважаемые Умы.
Хочу обратиться с тяжелым вопросом.

У меня есть макрос, разработанный программистом по имени ZVI (небезызвестным в определенных кругах).
Этот макрос двигает автофигуру Овал - то к одному пункту на листе, то к другому.

Подскажите, как заставить автофигуру - двигаться по маршруту, указанному в таблице?
(В таблице указаны координаты пунктов поочередного перемещения автофигуры Овал.)
К сообщению приложен файл: 34534534.xlsm(22Kb)
 
Ответить
СообщениеЗдравствуйте, уважаемые Умы.
Хочу обратиться с тяжелым вопросом.

У меня есть макрос, разработанный программистом по имени ZVI (небезызвестным в определенных кругах).
Этот макрос двигает автофигуру Овал - то к одному пункту на листе, то к другому.

Подскажите, как заставить автофигуру - двигаться по маршруту, указанному в таблице?
(В таблице указаны координаты пунктов поочередного перемещения автофигуры Овал.)

Автор - OlegSmirnov
Дата добавления - 07.08.2017 в 11:57
Manyasha Дата: Понедельник, 07.08.2017, 13:12 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 1990
Репутация: 819 ±
Замечаний: 0% ±

Excel 2010, 2016
OlegSmirnov, здравствуйте, попробуйте так:
[vba]
Код
' ZVI:2011-09-17 для Юрия_М
' Анимационное перемещение объекта Obj1 в центр объекта Obj2
Sub Obj1ToObj2_1(Obj1, Obj2, Optional Steps = 20)
  Const dt# = 0.02
  Dim x1#, x2#, y1#, y2#, x#, y#, t!
  Dim l1#, t1#, w1#, h1#, l2#, t2#, w2#, h2#
  
  With Obj1
    l1 = .Left: t1 = .Top: w1 = .Width: h1 = .Height
  End With
  l2 = Obj2(1, 1): t2 = Obj2(1, 2)
'  With Obj2
'    l2 = .Left: t2 = .Top: w2 = .Width: h2 = .Height
'  End With
  x1 = l1 + w1 / 2
  y1 = t1 + h1 / 2
  x2 = l2 ' + w2 / 2
  y2 = t2 ' + h2 / 2
  With Obj1
    For x = x1 To x2 Step (x2 - x1) / Steps
      y = (x2 * y1 - x1 * y2 - (y1 - y2) * x) / (x2 - x1)
      .Left = x - w1 / 2
      .Top = y - h1 / 2
      t = Timer + dt
      While Timer < t:  Wend
      DoEvents:
    Next
    x = x2: y = y2: .Left = x - w1 / 2: .Top = y - h1 / 2
    DoEvents
  End With
End Sub
[/vba][vba]
Код
Sub test()
  Dim lr&, i&
  
  With Лист1
    lr = .Cells(Rows.Count, "n").End(xlUp).Row
    For i = 6 To lr
        Obj1ToObj2_1 .Shapes("Oval 1"), .Cells(i, "n").Resize(, 2).Value
    Next i
  End With
End Sub
[/vba]
К сообщению приложен файл: 34534534-1.xlsm(24Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеOlegSmirnov, здравствуйте, попробуйте так:
[vba]
Код
' ZVI:2011-09-17 для Юрия_М
' Анимационное перемещение объекта Obj1 в центр объекта Obj2
Sub Obj1ToObj2_1(Obj1, Obj2, Optional Steps = 20)
  Const dt# = 0.02
  Dim x1#, x2#, y1#, y2#, x#, y#, t!
  Dim l1#, t1#, w1#, h1#, l2#, t2#, w2#, h2#
  
  With Obj1
    l1 = .Left: t1 = .Top: w1 = .Width: h1 = .Height
  End With
  l2 = Obj2(1, 1): t2 = Obj2(1, 2)
'  With Obj2
'    l2 = .Left: t2 = .Top: w2 = .Width: h2 = .Height
'  End With
  x1 = l1 + w1 / 2
  y1 = t1 + h1 / 2
  x2 = l2 ' + w2 / 2
  y2 = t2 ' + h2 / 2
  With Obj1
    For x = x1 To x2 Step (x2 - x1) / Steps
      y = (x2 * y1 - x1 * y2 - (y1 - y2) * x) / (x2 - x1)
      .Left = x - w1 / 2
      .Top = y - h1 / 2
      t = Timer + dt
      While Timer < t:  Wend
      DoEvents:
    Next
    x = x2: y = y2: .Left = x - w1 / 2: .Top = y - h1 / 2
    DoEvents
  End With
End Sub
[/vba][vba]
Код
Sub test()
  Dim lr&, i&
  
  With Лист1
    lr = .Cells(Rows.Count, "n").End(xlUp).Row
    For i = 6 To lr
        Obj1ToObj2_1 .Shapes("Oval 1"), .Cells(i, "n").Resize(, 2).Value
    Next i
  End With
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 07.08.2017 в 13:12
OlegSmirnov Дата: Понедельник, 07.08.2017, 21:01 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Manyasha, спасибо, все работает как надо.
 
Ответить
СообщениеManyasha, спасибо, все работает как надо.

Автор - OlegSmirnov
Дата добавления - 07.08.2017 в 21:01
Мир MS Excel » Вопросы и решения » Вопросы по VBA » как заставить фигуру двигаться по маршруту в таблице (Макросы/Sub)
Страница 1 из 11
Поиск:

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