Координаты крайних фигур по неортогональным направлениям - Мир MS Excel

Регистрация

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

= Мир MS Excel/Координаты крайних фигур по неортогональным направлениям - Мир MS Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Координаты крайних фигур по неортогональным направлениям (Макросы/Sub)

Координаты крайних фигур по неортогональным направлениям

Дата: Воскресенье, 03.09.2017, 13:08 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 97

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Здравствуйте, уважаемые программисты.
Помогите разобраться с проблемой.

Есть макрос, который для множества автофигур на листе - определяет координаты крайних - верхней,нижней,правой и левой фигуры.

Как заставить этот макрос - определить координаты крайних фигур по направлениям - право-верх, право-низ, лево-низ, лево-верх?
(Эти направления - я называю неортогональными, поскольку они направлены - по диагонали)

К сообщению приложен файл: 732457.xls (90.5 Kb)

Ответить

Дата: Воскресенье, 03.09.2017, 14:05 | Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 581

Репутация: 271 ±

Замечаний: 0% ±

2016, 365

Доброе время суток.
Да, всё тоже самое, просто предварительно поворачиваетесистему координат на требуемый "неортогональный" угол.
Успехов.

Ответить

Дата: Воскресенье, 03.09.2017, 15:15 | Сообщение № 3

Группа: Пользователи

Ранг: Участник

Сообщений: 97

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

anvg, а макросом это как сделать ?

Ответить

Дата: Воскресенье, 03.09.2017, 18:04 | Сообщение № 4

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Цитата OlegSmirnov, 03.09.2017 в 15:15, в сообщении № 3 ()

макросом это как сделать

Запустить не пробовали?
Рекомендую. Очень помогает.

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Воскресенье, 03.09.2017, 18:05

Ответить

Дата: Воскресенье, 03.09.2017, 18:47 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 97

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

RAN, что именно запустить ?

Ответить

Дата: Воскресенье, 03.09.2017, 18:59 | Сообщение № 6

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Как что? Макрос, конечно.
Если у вас его нет, то, предварительно, желательно написать.

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Понедельник, 04.09.2017, 15:05 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 97

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

RAN, вот значит как....
Не хотите значит помочь - новичку, робко делающему первые шаги в большом и незнакомом мире экселя....

Ответить

Дата: Понедельник, 04.09.2017, 19:06 | Сообщение № 8

Группа: Заблокированные

Ранг: Участник клуба

Сообщений: 3442

Репутация: 929 ±

Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG

Цитата

незнакомом мире экселя....

Excel-то тут причём - у вас есть макрос, в него нужно добавить формулы для поворота системы координат - ссылка в сообщении №2. Между "помочь" и "сделать за" большая разница

Ответить

Дата: Понедельник, 04.09.2017, 21:43 | Сообщение № 9

Группа: Пользователи

Ранг: Участник

Сообщений: 97

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

buchlotnik, так непонятно же ничего !

Дана система уравнений.
И как эту систему уравнений в макрос запихать ?

Ответить

Дата: Понедельник, 04.09.2017, 22:01 | Сообщение № 10

Группа: Заблокированные

Ранг: Участник клуба

Сообщений: 3442

Репутация: 929 ±

Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG

какая система уравнений? это просто две формулы для расчёта абсциссы и ординаты в повёрнутой системе координат - поворачиваем на 45 градусов и используем имеющийся макрос для выявления крайних

Ответить

Дата: Вторник, 05.09.2017, 12:45 | Сообщение № 11

Группа: Пользователи

Ранг: Участник

Сообщений: 97

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

buchlotnik, вот вы говорите - абсциссы и ординаты.
А в имеющемся макросе - нет обозначений x и y.

Ответить

Дата: Вторник, 05.09.2017, 14:12 | Сообщение № 12

Группа: Пользователи

Ранг: Новичок

Сообщений: 11

Репутация: 4 ±

Замечаний: 0% ±

Excel 2010

Залью свой вариант построения.

К сообщению приложен файл: 1588689.zip (51.2 Kb)

Сообщение отредактировал CAHO - Вторник, 05.09.2017, 15:03

Ответить

Дата: Вторник, 05.09.2017, 16:51 | Сообщение № 13

Группа: Заблокированные

Ранг: Участник клуба

Сообщений: 3442

Репутация: 929 ±

Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG

Цитата

нет обозначений x и y

цитата из вашей прошлой темы:

Цитата

У шейпов нет X и Y, а есть всякие .Top, .Left и т.д.

и вообще какая разница какой буквой обозначена горизонтальная координата?

Ответить

Дата: Вторник, 05.09.2017, 18:01 | Сообщение № 14

Группа: Пользователи

Ранг: Участник

Сообщений: 97

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

buchlotnik, а как в макросе записать операцию - cos(45) ?

Ответить

Дата: Вторник, 05.09.2017, 18:05 | Сообщение № 15

Группа: Заблокированные

Ранг: Участник клуба

Сообщений: 3442

Репутация: 929 ±

Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG

OlegSmirnov, 2^(-0.5),

да и не нужен он там-сейчас с телефона не удобно - вечером отпишусь

Сообщение отредактировал buchlotnik - Вторник, 05.09.2017, 22:19

Ответить

Дата: Вторник, 05.09.2017, 22:14 | Сообщение № 16

Группа: Заблокированные

Ранг: Участник клуба

Сообщений: 3442

Репутация: 929 ±

Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG

По модулю sin(-45)=cos(-45), значит, можно вынести за скобки; сами координаты нас не интересуют, интересует сравнение - значит, и умножать не обязательно. Координаты в новой системе - тупо сумма или разница текущих - в зависимости от того, абсцисса или ордината - оптимизацией не занимался, дополнил имеющийся код

[vba]

Код

Sub coord2()
    Dim a(1 To 8, 1 To 5), i%, j%
    With ActiveSheet.Shapes(1)
        For i = 1 To 8
            a(i, 1) = .Left + .Width / 2
            a(i, 2) = .Top - .Height / 2
            a(i, 3) = .Name
            a(i, 4) = a(i, 1) - a(i, 2)
            a(i, 5) = a(i, 1) + a(i, 2)
        Next
    End With

    For i = 1 To ActiveSheet.Shapes.Count
        With ActiveSheet.Shapes(i)
            If .Top - .Height / 2 < a(1, 2) Then a(1, 1) = .Left + .Width / _
                2: a(1, 2) = .Top - .Height / 2: a(1, 3) = .Name: a(1, 4) = a(1, _
                1) - a(1, 2): a(1, 5) = a(1, 1) + a(1, 2)
            If ((.Left + .Width / 2) + (.Top - .Height / 2)) < a(2, 5) Then _
                a(2, 1) = .Left + .Width / 2: a(2, 2) = .Top - .Height / 2: a(2, _
                3) = .Name: a(2, 4) = a(2, 1) - a(2, 2): a(2, 5) = a(2, 1) + _
                a(2, 2)
            If .Left + .Width / 2 < a(3, 1) Then a(3, 1) = .Left + .Width / _
                2: a(3, 2) = .Top - .Height / 2: a(3, 3) = .Name: a(3, 4) = a(3, _
                1) - a(3, 2): a(3, 5) = a(3, 1) + a(3, 2)
            If ((.Left + .Width / 2) - (.Top - .Height / 2)) < a(4, 4) Then _
                a(4, 1) = .Left + .Width / 2: a(4, 2) = .Top - .Height / 2: a(4, _
                3) = .Name: a(4, 4) = a(4, 1) - a(4, 2): a(4, 5) = a(4, 1) + _
                a(4, 2)
            If .Top - .Height / 2 > a(5, 2) Then a(5, 1) = .Left + .Width / _
                2: a(5, 2) = .Top - .Height / 2: a(5, 3) = .Name: a(5, 4) = a(5, _
                1) - a(5, 2): a(5, 5) = a(5, 1) + a(5, 2)
            If ((.Left + .Width / 2) + (.Top - .Height / 2)) > a(6, 5) Then _
                a(6, 1) = .Left + .Width / 2: a(6, 2) = .Top - .Height / 2: a(6, _
                3) = .Name: a(6, 4) = a(6, 1) - a(6, 2): a(6, 5) = a(6, 1) + _
                a(6, 2)
            If .Left + .Width / 2 > a(7, 1) Then a(7, 1) = .Left + .Width / _
                2: a(7, 2) = .Top - .Height / 2: a(7, 3) = .Name: a(7, 4) = a(7, _
                1) - a(7, 2): a(7, 5) = a(7, 1) + a(7, 2)
            If ((.Left + .Width / 2) - (.Top - .Height / 2)) > a(8, 4) Then _
                a(8, 1) = .Left + .Width / 2: a(8, 2) = .Top - .Height / 2: a(8, _
                3) = .Name: a(8, 4) = a(8, 1) - a(8, 2): a(8, 5) = a(8, 1) + _
                a(8, 2)
        End With
    Next i

    [Start2].Offset(1, 1).Resize(8, 3) = a
End Sub

[/vba]

По модулю sin(-45)=cos(-45), значит, можно вынести за скобки; сами координаты нас не интересуют, интересует сравнение - значит, и умножать не обязательно. Координаты в новой системе - тупо сумма или разница текущих - в зависимости от того, абсцисса или ордината - оптимизацией не занимался, дополнил имеющийся код

[vba]

Код

Sub coord2()
    Dim a(1 To 8, 1 To 5), i%, j%
    With ActiveSheet.Shapes(1)
        For i = 1 To 8
            a(i, 1) = .Left + .Width / 2
            a(i, 2) = .Top - .Height / 2
            a(i, 3) = .Name
            a(i, 4) = a(i, 1) - a(i, 2)
            a(i, 5) = a(i, 1) + a(i, 2)
        Next
    End With

    For i = 1 To ActiveSheet.Shapes.Count
        With ActiveSheet.Shapes(i)
            If .Top - .Height / 2 < a(1, 2) Then a(1, 1) = .Left + .Width / _
                2: a(1, 2) = .Top - .Height / 2: a(1, 3) = .Name: a(1, 4) = a(1, _
                1) - a(1, 2): a(1, 5) = a(1, 1) + a(1, 2)
            If ((.Left + .Width / 2) + (.Top - .Height / 2)) < a(2, 5) Then _
                a(2, 1) = .Left + .Width / 2: a(2, 2) = .Top - .Height / 2: a(2, _
                3) = .Name: a(2, 4) = a(2, 1) - a(2, 2): a(2, 5) = a(2, 1) + _
                a(2, 2)
            If .Left + .Width / 2 < a(3, 1) Then a(3, 1) = .Left + .Width / _
                2: a(3, 2) = .Top - .Height / 2: a(3, 3) = .Name: a(3, 4) = a(3, _
                1) - a(3, 2): a(3, 5) = a(3, 1) + a(3, 2)
            If ((.Left + .Width / 2) - (.Top - .Height / 2)) < a(4, 4) Then _
                a(4, 1) = .Left + .Width / 2: a(4, 2) = .Top - .Height / 2: a(4, _
                3) = .Name: a(4, 4) = a(4, 1) - a(4, 2): a(4, 5) = a(4, 1) + _
                a(4, 2)
            If .Top - .Height / 2 > a(5, 2) Then a(5, 1) = .Left + .Width / _
                2: a(5, 2) = .Top - .Height / 2: a(5, 3) = .Name: a(5, 4) = a(5, _
                1) - a(5, 2): a(5, 5) = a(5, 1) + a(5, 2)
            If ((.Left + .Width / 2) + (.Top - .Height / 2)) > a(6, 5) Then _
                a(6, 1) = .Left + .Width / 2: a(6, 2) = .Top - .Height / 2: a(6, _
                3) = .Name: a(6, 4) = a(6, 1) - a(6, 2): a(6, 5) = a(6, 1) + _
                a(6, 2)
            If .Left + .Width / 2 > a(7, 1) Then a(7, 1) = .Left + .Width / _
                2: a(7, 2) = .Top - .Height / 2: a(7, 3) = .Name: a(7, 4) = a(7, _
                1) - a(7, 2): a(7, 5) = a(7, 1) + a(7, 2)
            If ((.Left + .Width / 2) - (.Top - .Height / 2)) > a(8, 4) Then _
                a(8, 1) = .Left + .Width / 2: a(8, 2) = .Top - .Height / 2: a(8, _
                3) = .Name: a(8, 4) = a(8, 1) - a(8, 2): a(8, 5) = a(8, 1) + _
                a(8, 2)
        End With
    Next i

    [Start2].Offset(1, 1).Resize(8, 3) = a
End Sub

[/vba]

К сообщению приложен файл: 732457-1-.xlsm (22.9 Kb)

Сообщение отредактировал buchlotnik - Вторник, 05.09.2017, 22:19

Ответить

СообщениеПо модулю sin(-45)=cos(-45), значит, можно вынести за скобки; сами координаты нас не интересуют, интересует сравнение - значит, и умножать не обязательно. Координаты в новой системе - тупо сумма или разница текущих - в зависимости от того, абсцисса или ордината - оптимизацией не занимался, дополнил имеющийся код

[vba]

Код

Sub coord2()
    Dim a(1 To 8, 1 To 5), i%, j%
    With ActiveSheet.Shapes(1)
        For i = 1 To 8
            a(i, 1) = .Left + .Width / 2
            a(i, 2) = .Top - .Height / 2
            a(i, 3) = .Name
            a(i, 4) = a(i, 1) - a(i, 2)
            a(i, 5) = a(i, 1) + a(i, 2)
        Next
    End With

    For i = 1 To ActiveSheet.Shapes.Count
        With ActiveSheet.Shapes(i)
            If .Top - .Height / 2 < a(1, 2) Then a(1, 1) = .Left + .Width / _
                2: a(1, 2) = .Top - .Height / 2: a(1, 3) = .Name: a(1, 4) = a(1, _
                1) - a(1, 2): a(1, 5) = a(1, 1) + a(1, 2)
            If ((.Left + .Width / 2) + (.Top - .Height / 2)) < a(2, 5) Then _
                a(2, 1) = .Left + .Width / 2: a(2, 2) = .Top - .Height / 2: a(2, _
                3) = .Name: a(2, 4) = a(2, 1) - a(2, 2): a(2, 5) = a(2, 1) + _
                a(2, 2)
            If .Left + .Width / 2 < a(3, 1) Then a(3, 1) = .Left + .Width / _
                2: a(3, 2) = .Top - .Height / 2: a(3, 3) = .Name: a(3, 4) = a(3, _
                1) - a(3, 2): a(3, 5) = a(3, 1) + a(3, 2)
            If ((.Left + .Width / 2) - (.Top - .Height / 2)) < a(4, 4) Then _
                a(4, 1) = .Left + .Width / 2: a(4, 2) = .Top - .Height / 2: a(4, _
                3) = .Name: a(4, 4) = a(4, 1) - a(4, 2): a(4, 5) = a(4, 1) + _
                a(4, 2)
            If .Top - .Height / 2 > a(5, 2) Then a(5, 1) = .Left + .Width / _
                2: a(5, 2) = .Top - .Height / 2: a(5, 3) = .Name: a(5, 4) = a(5, _
                1) - a(5, 2): a(5, 5) = a(5, 1) + a(5, 2)
            If ((.Left + .Width / 2) + (.Top - .Height / 2)) > a(6, 5) Then _
                a(6, 1) = .Left + .Width / 2: a(6, 2) = .Top - .Height / 2: a(6, _
                3) = .Name: a(6, 4) = a(6, 1) - a(6, 2): a(6, 5) = a(6, 1) + _
                a(6, 2)
            If .Left + .Width / 2 > a(7, 1) Then a(7, 1) = .Left + .Width / _
                2: a(7, 2) = .Top - .Height / 2: a(7, 3) = .Name: a(7, 4) = a(7, _
                1) - a(7, 2): a(7, 5) = a(7, 1) + a(7, 2)
            If ((.Left + .Width / 2) - (.Top - .Height / 2)) > a(8, 4) Then _
                a(8, 1) = .Left + .Width / 2: a(8, 2) = .Top - .Height / 2: a(8, _
                3) = .Name: a(8, 4) = a(8, 1) - a(8, 2): a(8, 5) = a(8, 1) + _
                a(8, 2)
        End With
    Next i

    [Start2].Offset(1, 1).Resize(8, 3) = a
End Sub

[/vba]

Автор - buchlotnik
Дата добавления - 05.09.2017 в 22:14

Дата: Вторник, 05.09.2017, 22:19 | Сообщение № 17

Группа: Пользователи

Ранг: Участник

Сообщений: 97

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

buchlotnik, вроде все работает.
Большое вам спасибо и низкий поклон.

Ответить

Дата: Вторник, 05.09.2017, 22:36 | Сообщение № 18

Группа: Заблокированные

Ранг: Участник клуба

Сообщений: 3442

Репутация: 929 ±

Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG

Так чутка поаккуратнее будет:

К сообщению приложен файл: 1234567.xlsm (22.5 Kb)

Сообщение отредактировал buchlotnik - Вторник, 05.09.2017, 22:42

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Координаты крайних фигур по неортогональным направлениям (Макросы/Sub)

Страница 1 из 1
1

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