a=координаты верхней границы 1 фигуры b=координаты нижней границы 1 фигуры с=координаты левой границы 1 фигуры d=координаты правой границы 1 фигуры e=координаты верхней границы 2 фигуры f=координаты нижней границы 2 фигуры g=координаты левой границы 2 фигуры h=координаты правой границы 2 фигуры i=application.median(a,b,e,f) j=application.median(c,d,g,h) If i < a And i > b And j > c And j < d then Надвинуто=true
[/vba]
[vba]
Код
a=координаты верхней границы 1 фигуры b=координаты нижней границы 1 фигуры с=координаты левой границы 1 фигуры d=координаты правой границы 1 фигуры e=координаты верхней границы 2 фигуры f=координаты нижней границы 2 фигуры g=координаты левой границы 2 фигуры h=координаты правой границы 2 фигуры i=application.median(a,b,e,f) j=application.median(c,d,g,h) If i < a And i > b And j > c And j < d then Надвинуто=true
krosav4ig, вы в своем коде указали такой параметр "координаты верхней границы 2 фигуры" А как вы определили - где вторая фигура, где третья - если их на листе огромное количество.
С первой фигурой - понятно - это "Овал 1". А остальные-то фигуры как определить ?
krosav4ig, вы в своем коде указали такой параметр "координаты верхней границы 2 фигуры" А как вы определили - где вторая фигура, где третья - если их на листе огромное количество.
С первой фигурой - понятно - это "Овал 1". А остальные-то фигуры как определить ?SergVrn
dim фигура2 as shape with activesheet with .shapes("Овал 1") 'вычисление координат границ Овала 1 end with 'проход циклом по объектам в коллекции shapes for each фигура2 in .shapes if фигура2.name<>"Овал 1" then 'вычисление координат границ фигуры2 и пересечения с овалом endif next end with
[/vba]
[vba]
Код
dim фигура2 as shape with activesheet with .shapes("Овал 1") 'вычисление координат границ Овала 1 end with 'проход циклом по объектам в коллекции shapes for each фигура2 in .shapes if фигура2.name<>"Овал 1" then 'вычисление координат границ фигуры2 и пересечения с овалом endif next end with
Применил вашу схему, но вот что-то не работает. Макрос выглядит так: [vba]
Код
Sub Макрос1()
Dim фигура2 As Shape With ActiveSheet With .Shapes("Овал 1") 'вычисление координат границ Овала 1 a = .Top b = .Top + .Height c = .Left d = .Left + .Width
End With
'проход циклом по объектам в коллекции shapes For Each фигура2 In .shapes If sh.Name <> "Овал 1" Then
'вычисление координат границ фигуры2 и пересечения с овалом e = .Top f = .Top + .Height g = .Left h = .Left + .Width i = Application.Median(a, b, e, f) j = Application.Median(c, d, g, h) If i < a And i > b And j > c And j < d Then Надвинуто = True
End If Next End With
End Sub
[/vba] Выдает ошибку : Run-time error 438: Object doesnt support this property or method И подсвечивает строку: For Each фигура2 In .spapes
Подскажите как устранить данную ошибку ?
krosav4ig, спасибо за ответ.
Применил вашу схему, но вот что-то не работает. Макрос выглядит так: [vba]
Код
Sub Макрос1()
Dim фигура2 As Shape With ActiveSheet With .Shapes("Овал 1") 'вычисление координат границ Овала 1 a = .Top b = .Top + .Height c = .Left d = .Left + .Width
End With
'проход циклом по объектам в коллекции shapes For Each фигура2 In .shapes If sh.Name <> "Овал 1" Then
'вычисление координат границ фигуры2 и пересечения с овалом e = .Top f = .Top + .Height g = .Left h = .Left + .Width i = Application.Median(a, b, e, f) j = Application.Median(c, d, g, h) If i < a And i > b And j > c And j < d Then Надвинуто = True
End If Next End With
End Sub
[/vba] Выдает ошибку : Run-time error 438: Object doesnt support this property or method И подсвечивает строку: For Each фигура2 In .spapes
Sub Макрос1() Dim фигура2 As Shape With ActiveSheet With .Shapes("Овал 1") 'вычисление координат границ Овала 1 'Здесь контекст- ActiveSheet.Shapes("Овал 1") , поэтому следующие 4 строчки отрабатывают корректно a = .Top b = .Top + .Height c = .Left d = .Left + .Width End With 'проход фиклом по объектам в коллекции shapes For Each фигура2 In .Shapes If фигура2.Name <> "Овал 1" Then 'вычисление координат границ фигуры2 и пересечения с овалом 'а вот здесь контекст - activesheet и следующие 4 не будут работать (в классе worksheet нету свосйтв top и left) 'чтобы работало нужно или обернуть их в конструкцию with фигура2 ... end with, или писать e=фигура2.top e = .Top f = .Top + .Height g = .Left h = .Left + .Width i = Application.Median(a, b, e, f) j = Application.Median(c, d, g, h) If i < a And i > b And j > c And j < d Then Надвинуто = True End If Next End With End Sub
[/vba]
SergVrn, вместо sh.name нужно фигура2.name [vba]
Код
Sub Макрос1() Dim фигура2 As Shape With ActiveSheet With .Shapes("Овал 1") 'вычисление координат границ Овала 1 'Здесь контекст- ActiveSheet.Shapes("Овал 1") , поэтому следующие 4 строчки отрабатывают корректно a = .Top b = .Top + .Height c = .Left d = .Left + .Width End With 'проход фиклом по объектам в коллекции shapes For Each фигура2 In .Shapes If фигура2.Name <> "Овал 1" Then 'вычисление координат границ фигуры2 и пересечения с овалом 'а вот здесь контекст - activesheet и следующие 4 не будут работать (в классе worksheet нету свосйтв top и left) 'чтобы работало нужно или обернуть их в конструкцию with фигура2 ... end with, или писать e=фигура2.top e = .Top f = .Top + .Height g = .Left h = .Left + .Width i = Application.Median(a, b, e, f) j = Application.Median(c, d, g, h) If i < a And i > b And j > c And j < d Then Надвинуто = True End If Next End With End Sub
krosav4ig, спасибо. Теперь макрос выглядит вот так: [vba]
Код
Sub Макрос1()
Dim фигура2 As Shape With ActiveSheet With .Shapes("Овал 1") a = .Top b = .Top + .Height c = .Left d = .Left + .Width End With
For Each фигура2 In .Shapes If фигура2.Name <> "Овал 1" Then e = фигура2.Top f = фигура2.Top + фигура2.Height g = фигура2.Left h = фигура2.Left + фигура2.Width i = Application.Median(a, b, e, f) j = Application.Median(c, d, g, h) If i < a And i > b And j > c And j < d Then Надвинуто = True
End If Next End With
End Sub
[/vba]
Ошибки макрос теперь не выдает. Но он вроде и не делает ничего.
Я нажимаю на кнопку - и ничего не происходит. В столбце N - ничего не появляется.
krosav4ig, спасибо. Теперь макрос выглядит вот так: [vba]
Код
Sub Макрос1()
Dim фигура2 As Shape With ActiveSheet With .Shapes("Овал 1") a = .Top b = .Top + .Height c = .Left d = .Left + .Width End With
For Each фигура2 In .Shapes If фигура2.Name <> "Овал 1" Then e = фигура2.Top f = фигура2.Top + фигура2.Height g = фигура2.Left h = фигура2.Left + фигура2.Width i = Application.Median(a, b, e, f) j = Application.Median(c, d, g, h) If i < a And i > b And j > c And j < d Then Надвинуто = True
End If Next End With
End Sub
[/vba]
Ошибки макрос теперь не выдает. Но он вроде и не делает ничего.
Я нажимаю на кнопку - и ничего не происходит. В столбце N - ничего не появляется.SergVrn
Или под Цитата SergVrn, 03.03.2019 в 11:07, в сообщении № 1 ( писал(а)): Помогите решить вопрос с макросом. подразумевается что надо написать это макрос?
Вот и надо было написать что нужна кнопка по которой там будет то что нужно.
Или под Цитата SergVrn, 03.03.2019 в 11:07, в сообщении № 1 ( писал(а)): Помогите решить вопрос с макросом. подразумевается что надо написать это макрос?
Вот и надо было написать что нужна кнопка по которой там будет то что нужно.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Добрался таки до компа, вспомнил, что .Top отсчитывается сверху, поменял местами 2 знака > и < [vba]
Код
Option Explicit Sub DetectIntersection() Dim a&, b&, c&, d&, e&, f&, g&, h&, i&, j&, k%, arr$(), Фигура2 As Object, sCallerName$ Const ShName$ = "Oval 1" 'имя Фигуры1 With Application 'если макрос был запущен нажатием на шейп, пишем в переменную имя этого шейпа If TypeName(.Caller) = "Shape" Then sCallerName = .Caller.Name With ActiveSheet 'контекст - активный лист, (все вызовы .Свойство или .Метод на этом уровне вложенности обращаются к нему) With .Shapes(ShName) 'контекст - Шейп с именем ShName 'вычисление координат границ Фигуры1 a = .Top: b = a + .Height c = .Left: d = c + .Width End With ' co следующей строки контекст снова активный лист 'проход циклом по объектам в коллекции shapes For Each Фигура2 In .Shapes 'Если имя Фигуры1 <> имени Фигуры1 и <> sCallerName (имя шейпа, если этот макрос был запущен кликом по нему) If Фигура2.Name <> ShName And Фигура2.Name <> sCallerName Then With Фигура2 'контекст - Фигура2 e = .Top: f = .Top + .Height g = .Left: h = .Left + .Width End With ' co следующей строки контекст снова активный лист 'вычисления медиан вертикальных и горизонтальных координат Фигуры1 и Фигуры2 i = Application.Median(a, b, f, e) j = Application.Median(c, d, g, h) 'если точка с координатами = полученных медиан находится внутри шейпа ShName If i > a And i < b And j > c And j < d Then 'Переопределяем размерность массива ReDim Preserve arr(k) 'пишем в последний элемент массива имя Фигуры2 arr(k) = Фигура2.Name k = k + 1 End If End If Next 'область непустых ячеек, граничащих с N4 With .[N4].CurrentRegion 'смещаемся на 1 ячейку вниз и выбираем столбец N With Intersect(.Cells, .Offset(1), .Parent.Columns("N")) 'Очищаем значения выбранных ячеек On Error Resume Next .ClearContents On Error GoTo 0 End With 'пишем новые значения из массива arr, если он не пуст If i Then .Offset(1).Resize(k).Value = Application.Transpose(arr) End With End With End With End Sub
[/vba]
Добрался таки до компа, вспомнил, что .Top отсчитывается сверху, поменял местами 2 знака > и < [vba]
Код
Option Explicit Sub DetectIntersection() Dim a&, b&, c&, d&, e&, f&, g&, h&, i&, j&, k%, arr$(), Фигура2 As Object, sCallerName$ Const ShName$ = "Oval 1" 'имя Фигуры1 With Application 'если макрос был запущен нажатием на шейп, пишем в переменную имя этого шейпа If TypeName(.Caller) = "Shape" Then sCallerName = .Caller.Name With ActiveSheet 'контекст - активный лист, (все вызовы .Свойство или .Метод на этом уровне вложенности обращаются к нему) With .Shapes(ShName) 'контекст - Шейп с именем ShName 'вычисление координат границ Фигуры1 a = .Top: b = a + .Height c = .Left: d = c + .Width End With ' co следующей строки контекст снова активный лист 'проход циклом по объектам в коллекции shapes For Each Фигура2 In .Shapes 'Если имя Фигуры1 <> имени Фигуры1 и <> sCallerName (имя шейпа, если этот макрос был запущен кликом по нему) If Фигура2.Name <> ShName And Фигура2.Name <> sCallerName Then With Фигура2 'контекст - Фигура2 e = .Top: f = .Top + .Height g = .Left: h = .Left + .Width End With ' co следующей строки контекст снова активный лист 'вычисления медиан вертикальных и горизонтальных координат Фигуры1 и Фигуры2 i = Application.Median(a, b, f, e) j = Application.Median(c, d, g, h) 'если точка с координатами = полученных медиан находится внутри шейпа ShName If i > a And i < b And j > c And j < d Then 'Переопределяем размерность массива ReDim Preserve arr(k) 'пишем в последний элемент массива имя Фигуры2 arr(k) = Фигура2.Name k = k + 1 End If End If Next 'область непустых ячеек, граничащих с N4 With .[N4].CurrentRegion 'смещаемся на 1 ячейку вниз и выбираем столбец N With Intersect(.Cells, .Offset(1), .Parent.Columns("N")) 'Очищаем значения выбранных ячеек On Error Resume Next .ClearContents On Error GoTo 0 End With 'пишем новые значения из массива arr, если он не пуст If i Then .Offset(1).Resize(k).Value = Application.Transpose(arr) End With End With End With End Sub