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

Вход

Регистрация

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

 

= Мир MS Excel/Соответствие точек массива некоторым выпуклым многоугольника - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Соответствие точек массива некоторым выпуклым многоугольника (Макросы/Sub)
Соответствие точек массива некоторым выпуклым многоугольника
_AmiGO_ Дата: Вторник, 08.12.2020, 19:07 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Здравствуйте. Я понимаю, что задача очень схожа с теми, что уже решались на этом(и не только) форуме. Но все-таки, для моего случая, моих знаний не хватает чтобы адаптировать имеющиеся решения под мои нужды. Поэтому, прошу Вас сделать для меня решение, если возможно.
Дано:
-Некоторое количество выпуклых многоугольников с известными координатами вершин.
-Массив точек с известными координатами. Количество точек неизвестно.
Задача:
Проверить, находится ли точка в пределах какого-либо из многоугольников и присвоить соответствующий номер многоугольника, в котором она находится(колонка D в примере).
Пересечения многоугольников исключены. Если точка не находится ни в одном многоугольнике-ничего не присваивать.
Если точка находится на линии многоугольника-без разницы, присваивать или нет, не критично.
Если точка находится на вершине многоугольника-без разницы, присваивать или нет, не критично.

Как минимум, решение хотя бы 4-х угольниками. В идеале - n угольниками(для масштабируемости, в случае надобности).
Как минимум, решение хотя бы для одного 4-х угольника. В идеале - для любого имеющегося количества многоугольников.
По возможности - уметь обрабатывать(или как-то информировать) пересечения многоугольников. Хоть и пересечения исключены, человеческий фактор ошибки никто не отменял.

Файлы одинаковые, только разных версий. Версия Excel, в которой будет выполнена задача не критична.

Если задача слишком тяжелая для бесплатной помощи, прошу указать подобный пример и как правильно его модифицировать под мою задачу. Или указать ориентировочную стоимость работ.
Заранее благодарю за помощь.
К сообщению приложен файл: __.xls (28.0 Kb) · 0337599.xlsx (10.3 Kb)


Сообщение отредактировал _AmiGO_ - Среда, 09.12.2020, 12:05
 
Ответить
СообщениеЗдравствуйте. Я понимаю, что задача очень схожа с теми, что уже решались на этом(и не только) форуме. Но все-таки, для моего случая, моих знаний не хватает чтобы адаптировать имеющиеся решения под мои нужды. Поэтому, прошу Вас сделать для меня решение, если возможно.
Дано:
-Некоторое количество выпуклых многоугольников с известными координатами вершин.
-Массив точек с известными координатами. Количество точек неизвестно.
Задача:
Проверить, находится ли точка в пределах какого-либо из многоугольников и присвоить соответствующий номер многоугольника, в котором она находится(колонка D в примере).
Пересечения многоугольников исключены. Если точка не находится ни в одном многоугольнике-ничего не присваивать.
Если точка находится на линии многоугольника-без разницы, присваивать или нет, не критично.
Если точка находится на вершине многоугольника-без разницы, присваивать или нет, не критично.

Как минимум, решение хотя бы 4-х угольниками. В идеале - n угольниками(для масштабируемости, в случае надобности).
Как минимум, решение хотя бы для одного 4-х угольника. В идеале - для любого имеющегося количества многоугольников.
По возможности - уметь обрабатывать(или как-то информировать) пересечения многоугольников. Хоть и пересечения исключены, человеческий фактор ошибки никто не отменял.

Файлы одинаковые, только разных версий. Версия Excel, в которой будет выполнена задача не критична.

Если задача слишком тяжелая для бесплатной помощи, прошу указать подобный пример и как правильно его модифицировать под мою задачу. Или указать ориентировочную стоимость работ.
Заранее благодарю за помощь.

Автор - _AmiGO_
Дата добавления - 08.12.2020 в 19:07
прохожий2019 Дата: Среда, 09.12.2020, 08:32 | Сообщение № 2
Группа: Проверенные
Ранг: Старожил
Сообщений: 1241
Репутация: 317 ±
Замечаний: 0% ±

365 Beta Channel
два файла и ни в одном нет примера исходных данных
 
Ответить
Сообщениедва файла и ни в одном нет примера исходных данных

Автор - прохожий2019
Дата добавления - 09.12.2020 в 08:32
_AmiGO_ Дата: Среда, 09.12.2020, 12:06 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Потому что данные абсолютно любые. Заменил исходные файлы.
 
Ответить
СообщениеПотому что данные абсолютно любые. Заменил исходные файлы.

Автор - _AmiGO_
Дата добавления - 09.12.2020 в 12:06
Апострофф Дата: Четверг, 10.12.2020, 01:33 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 444
Репутация: 122 ±
Замечаний: 0% ±

Excel 1997
_AmiGO_, постарайтесь давать вменяемые координаты вершин ВЫПУКЛЫХ многоугольников, а не как в выложенных Вами примерах.
И пробуйте -
[vba]
Код
Sub MAIN()
Set T = Sheets("массив точек").Cells
Set M = Sheets("многоугольники").Cells
For R = 2 To T(T.Rows.Count, 1).End(xlUp).Row
  X = T(R, 2): Y = T(R, 3)
  For RR = 2 To M(M.Rows.Count, 1).End(xlUp).Row
    XY = Range(M(RR, 2), M(RR, M(RR, M.Columns.Count).End(xlToLeft).Column))
    SS = 0
    For I = 1 To UBound(XY, 2) Step 2
      S = Sgn((XY(1, I) - X) * (XY(1, (I + 2) Mod UBound(XY, 2) + 1) - Y) - (XY(1, (I + 1) Mod UBound(XY, 2) + 1) - X) * (XY(1, I + 1) - Y))
      If S Then If SS Then If S <> SS Then Exit For
      If S Then SS = S
    Next I
    If I > UBound(XY, 2) Then T(R, 4) = RR - 1: Exit For
  Next RR
Next R
End Sub
[/vba]
 
Ответить
Сообщение_AmiGO_, постарайтесь давать вменяемые координаты вершин ВЫПУКЛЫХ многоугольников, а не как в выложенных Вами примерах.
И пробуйте -
[vba]
Код
Sub MAIN()
Set T = Sheets("массив точек").Cells
Set M = Sheets("многоугольники").Cells
For R = 2 To T(T.Rows.Count, 1).End(xlUp).Row
  X = T(R, 2): Y = T(R, 3)
  For RR = 2 To M(M.Rows.Count, 1).End(xlUp).Row
    XY = Range(M(RR, 2), M(RR, M(RR, M.Columns.Count).End(xlToLeft).Column))
    SS = 0
    For I = 1 To UBound(XY, 2) Step 2
      S = Sgn((XY(1, I) - X) * (XY(1, (I + 2) Mod UBound(XY, 2) + 1) - Y) - (XY(1, (I + 1) Mod UBound(XY, 2) + 1) - X) * (XY(1, I + 1) - Y))
      If S Then If SS Then If S <> SS Then Exit For
      If S Then SS = S
    Next I
    If I > UBound(XY, 2) Then T(R, 4) = RR - 1: Exit For
  Next RR
Next R
End Sub
[/vba]

Автор - Апострофф
Дата добавления - 10.12.2020 в 01:33
bmv98rus Дата: Четверг, 10.12.2020, 18:35 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4099
Репутация: 766 ±
Замечаний: 0% ±

Excel 2013/2016
Тут есть функция, которой наплевать на выпуклость, только правило последовательного обхода соблюдать.


Замечательный Временно просто медведь , процентов на 20.
 
Ответить
СообщениеТут есть функция, которой наплевать на выпуклость, только правило последовательного обхода соблюдать.

Автор - bmv98rus
Дата добавления - 10.12.2020 в 18:35
_AmiGO_ Дата: Воскресенье, 13.12.2020, 21:03 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Спасибо всем за помощь, но сам справился. Изменил чужой скрипт через дикие костыли, но работает.
Если кому пригодится, тему можно закрыть.

[vba]
Код
Const k2 = 2 / 3
Function diplom2(ByVal px As Double, ByVal py As Double) As Integer
Dim r As Integer
Dim stroka, stolbec, areaNumber As Integer
Dim КоличествоПересечений As Byte
Dim xx0, yy0 As Double
Dim Msg As String

x0 = px
y0 = py
stolbec = -1
stroka = 2
areaNumber = 0

DoAgain:
If areaNumber > 46 Then GoTo EndPoint2
КоличествоПересечений = 0
areaNumber = areaNumber + 1
stolbec = stolbec + 3
stroka = 2
'MsgBox ("stolbec=" & stolbec & " stroka=" & stroka & " areaNumber=" & areaNumber)
Do
'If stroka = 6 Then Exit Do
If Worksheets("areas").Cells(stroka + 1, stolbec) = "" Then Exit Do
If Пересекает(Worksheets("areas").Cells(stroka, stolbec), _
Worksheets("areas").Cells(stroka, stolbec + 1), _
Worksheets("areas").Cells(stroka + 1, stolbec), _
Worksheets("areas").Cells(stroka + 1, stolbec + 1), _
px, py) Then
КоличествоПересечений = КоличествоПересечений + 1
End If
stroka = stroka + 1
Loop
If КоличествоПересечений Mod 2 <> 0 Then GoTo EndPoint1
If КоличествоПересечений Mod 2 = 0 Then GoTo DoAgain

EndPoint1:
diplom2 = areaNumber
EndPoint2:
End Function

Private Function Пересекает(x1 As Double, y1 As Double, _
x2 As Double, y2 As Double, _
x0 As Double, y0 As Double) As Boolean
Dim x_min As Double, x_max As Double
Dim k1 As Double, b1 As Double, b2 As Double, x_ As Double

Пересекает = False

'If x1 = x2 Then x2 = x1 + 0.001 'для вертикальных отрезков!

If x1 > x2 Then
x_max = x1
x_min = x2
Else
x_max = x2
x_min = x1
End If

k1 = (y2 - y1) / (x2 - x1)
b1 = y1 - k1 * x1

b2 = y0 - k2 * x0

x_ = -(b2 - b1) / (k2 - k1)

If (x_ > x_min And x_ <= x_max) And (x_ > x0) Then Пересекает = True 'And (x_ > x0) при k=1
End Function
[/vba]


Сообщение отредактировал _AmiGO_ - Воскресенье, 13.12.2020, 21:05
 
Ответить
СообщениеСпасибо всем за помощь, но сам справился. Изменил чужой скрипт через дикие костыли, но работает.
Если кому пригодится, тему можно закрыть.

[vba]
Код
Const k2 = 2 / 3
Function diplom2(ByVal px As Double, ByVal py As Double) As Integer
Dim r As Integer
Dim stroka, stolbec, areaNumber As Integer
Dim КоличествоПересечений As Byte
Dim xx0, yy0 As Double
Dim Msg As String

x0 = px
y0 = py
stolbec = -1
stroka = 2
areaNumber = 0

DoAgain:
If areaNumber > 46 Then GoTo EndPoint2
КоличествоПересечений = 0
areaNumber = areaNumber + 1
stolbec = stolbec + 3
stroka = 2
'MsgBox ("stolbec=" & stolbec & " stroka=" & stroka & " areaNumber=" & areaNumber)
Do
'If stroka = 6 Then Exit Do
If Worksheets("areas").Cells(stroka + 1, stolbec) = "" Then Exit Do
If Пересекает(Worksheets("areas").Cells(stroka, stolbec), _
Worksheets("areas").Cells(stroka, stolbec + 1), _
Worksheets("areas").Cells(stroka + 1, stolbec), _
Worksheets("areas").Cells(stroka + 1, stolbec + 1), _
px, py) Then
КоличествоПересечений = КоличествоПересечений + 1
End If
stroka = stroka + 1
Loop
If КоличествоПересечений Mod 2 <> 0 Then GoTo EndPoint1
If КоличествоПересечений Mod 2 = 0 Then GoTo DoAgain

EndPoint1:
diplom2 = areaNumber
EndPoint2:
End Function

Private Function Пересекает(x1 As Double, y1 As Double, _
x2 As Double, y2 As Double, _
x0 As Double, y0 As Double) As Boolean
Dim x_min As Double, x_max As Double
Dim k1 As Double, b1 As Double, b2 As Double, x_ As Double

Пересекает = False

'If x1 = x2 Then x2 = x1 + 0.001 'для вертикальных отрезков!

If x1 > x2 Then
x_max = x1
x_min = x2
Else
x_max = x2
x_min = x1
End If

k1 = (y2 - y1) / (x2 - x1)
b1 = y1 - k1 * x1

b2 = y0 - k2 * x0

x_ = -(b2 - b1) / (k2 - k1)

If (x_ > x_min And x_ <= x_max) And (x_ > x0) Then Пересекает = True 'And (x_ > x0) при k=1
End Function
[/vba]

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

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