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

Вход

Регистрация

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

 

= Мир MS Excel/Замена в макросе - луча на отрезок. - Мир MS Excel

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

Excel 2016
Доброго дня. Помогите с решением непростого вопроса.

У меня есть макрос.
Суть его в том, что он выписывает в столбец P5:P20 - названия тех фигур, которые пересекает луч (бесконечная прямая).
Луч задается отрезком по координатам, представленным в таблице L4:M5.

Посоветуйте - как изменить макрос, чтобы он определял названия фигур, которые пересекает не луч, а сам отрезок ?
[vba]
Код

Option Explicit
  Private shp As Shape, sh As Shape, s$, k#, a#, x#, y#, ok As Boolean, x1#, x2#, y1#, y2#


Sub Линия1()
  'Dim shp As Shape, sh As Shape, s$, k#, a#, x#, y#, ok As Boolean, x1#, x2#, y1#, y2#
  s = Empty
  Range("P5:P33").ClearContents
Dim i&
  
  x1 = Range("L4"): y1 = Range("M4")
  x2 = Range("L5"): y2 = Range("M5")
  k = (y2 - y1) / (x2 - x1):  a = y1 - k * x1
  Set shp = ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)
  shp.Line.EndArrowheadStyle = msoArrowheadTriangle
  shp.Line.Weight = 2
  shp.Line.ForeColor.RGB = RGB(255, 0, 0)
  For Each sh In ActiveSheet.Shapes
    If sh.Name <> shp.Name Then
      x = sh.Left:  y = k * x + a:  ok = IsBetween(y, sh.Top, sh.Top + sh.Height)
      If Not ok Then x = sh.Left + sh.Width: y = k * x + a: ok = IsBetween(y, sh.Top, sh.Top + sh.Height)
      If Not ok Then y = sh.Top:  x = (a - y) / k: ok = IsBetween(x, sh.Left, sh.Left + sh.Width)
      If Not ok Then y = sh.Top + sh.Height: x = (a - y) / k: ok = IsBetween(x, sh.Left, sh.Left + sh.Width)
      If ok Then s = s & vbLf & sh.Name
   
        
    End If
    Next
  'MsgBox shp.Name & " intersect next:" & vbLf & s, , "Look at this"
  'Range("P5:P10").Value = Application.Transpose(s)
  'Debug.Print s

  Range("P5:P20").Value = Application.Transpose(Split(Mid(s, 2), vbLf))
  Range("P5:P20").Replace "#N/A", ""
       Application.OnTime DateAdd("s", 3, Now), "Delete1"

     
     
End Sub


Function IsBetween(x#, x1#, x2#)
  IsBetween = x >= x1 And x <= x2
End Function

Sub Delete1()
    shp.Delete
    Range("P5:P33").ClearContents
    ActiveSheet.Calculate
End Sub
[/vba]
К сообщению приложен файл: 4882688.xls(69.5 Kb)
 
Ответить
СообщениеДоброго дня. Помогите с решением непростого вопроса.

У меня есть макрос.
Суть его в том, что он выписывает в столбец P5:P20 - названия тех фигур, которые пересекает луч (бесконечная прямая).
Луч задается отрезком по координатам, представленным в таблице L4:M5.

Посоветуйте - как изменить макрос, чтобы он определял названия фигур, которые пересекает не луч, а сам отрезок ?
[vba]
Код

Option Explicit
  Private shp As Shape, sh As Shape, s$, k#, a#, x#, y#, ok As Boolean, x1#, x2#, y1#, y2#


Sub Линия1()
  'Dim shp As Shape, sh As Shape, s$, k#, a#, x#, y#, ok As Boolean, x1#, x2#, y1#, y2#
  s = Empty
  Range("P5:P33").ClearContents
Dim i&
  
  x1 = Range("L4"): y1 = Range("M4")
  x2 = Range("L5"): y2 = Range("M5")
  k = (y2 - y1) / (x2 - x1):  a = y1 - k * x1
  Set shp = ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)
  shp.Line.EndArrowheadStyle = msoArrowheadTriangle
  shp.Line.Weight = 2
  shp.Line.ForeColor.RGB = RGB(255, 0, 0)
  For Each sh In ActiveSheet.Shapes
    If sh.Name <> shp.Name Then
      x = sh.Left:  y = k * x + a:  ok = IsBetween(y, sh.Top, sh.Top + sh.Height)
      If Not ok Then x = sh.Left + sh.Width: y = k * x + a: ok = IsBetween(y, sh.Top, sh.Top + sh.Height)
      If Not ok Then y = sh.Top:  x = (a - y) / k: ok = IsBetween(x, sh.Left, sh.Left + sh.Width)
      If Not ok Then y = sh.Top + sh.Height: x = (a - y) / k: ok = IsBetween(x, sh.Left, sh.Left + sh.Width)
      If ok Then s = s & vbLf & sh.Name
   
        
    End If
    Next
  'MsgBox shp.Name & " intersect next:" & vbLf & s, , "Look at this"
  'Range("P5:P10").Value = Application.Transpose(s)
  'Debug.Print s

  Range("P5:P20").Value = Application.Transpose(Split(Mid(s, 2), vbLf))
  Range("P5:P20").Replace "#N/A", ""
       Application.OnTime DateAdd("s", 3, Now), "Delete1"

     
     
End Sub


Function IsBetween(x#, x1#, x2#)
  IsBetween = x >= x1 And x <= x2
End Function

Sub Delete1()
    shp.Delete
    Range("P5:P33").ClearContents
    ActiveSheet.Calculate
End Sub
[/vba]

Автор - Lizard
Дата добавления - 30.01.2019 в 13:19
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена в макросе - луча на отрезок. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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