Есть полигон на нем 19 точек, задана любая из них и необходимо для каждого участка найти кратчайшее расстояние
К примеру задана точка 6 и от нее нужно найти до каждого середины отрезка кратчайшее настояние: 6-Д - = 15/2 = 7,5 6-О = 22/2 = 11 Д-2 = 15+30/2 =30 и в таком духе для каждого отрезка для каждого пункта отправления
в ручную это делать весьма проблематично и долго. Пытался с помощью поиска решений сделать, писало что слишком много ячеек переменных по завершению необходимо получить что то в этом роде
Dim dic1 As Object
Sub aaa()
bbb
Dim y As Byte
Dim x As Byte
Dim s As String
Dim p As String
For y = 3 To 21
For x = Range("G1").Column To Range("Y1").Column
s = Cells(2, x).Value
p = Cells(y, Range("F1").Column).Value
If dic1(s).Exists(s & "-" & p) Then
Cells(y, x).Value = dic1(s)(s & "-" & p)
End If
Next
Next
End Sub
Sub bbb()
Set dic1 = GetOneNodLength
Dim dic2 As Object
Dim b As String
Dim c As String
Dim v1 As Variant
Dim v2 As Variant
Dim v3 As Variant
Dim step As Variant
For Each step In Array(1, 2)
For Each v1 In dic1.keys
Set dic2 = dic1(v1)
For Each v2 In dic2.keys
b = Split(v2, "-")(1)
For Each v3 In dic1(b).keys
c = Split(v3, "-")(1)
If Not dic1(v1).Exists(v1 & "-" & c) Then
dic1(v1)(v1 & "-" & c) = dic1(v1).Item(v2) + dic1(b).Item(v3)
End If
If dic1(v1)(v1 & "-" & c) > dic1(v1).Item(v2) + dic1(b).Item(v3) Then
dic1(v1)(v1 & "-" & c) = dic1(v1).Item(v2) + dic1(b).Item(v3)
End If
Next
Next
Next
Next
End Sub
Function GetOneNodLength() As Object
Dim y As Long
y = Cells(Rows.Count, 1).End(xlUp).Row
Dim a As Variant
a = Range(Cells(4, 1), Cells(y, 3))
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim v As Variant
Dim i As Variant
For y = 1 To UBound(a, 1)
v = Split(a(y, 1), "-")
For i = 0 To 1
If Not dic.Exists(v(i)) Then
Set dic(v(i)) = CreateObject("Scripting.Dictionary")
End If
dic(v(i))(v(i) & "-" & v(1 - i)) = a(y, 3)
dic(v(i))(v(i) & "-" & v(i)) = 0
Next
Next
Set GetOneNodLength = dic
End Function
Макрос заполнит таблицу расстояний. Заполнит полные расстояния, не середины отрезков. И в таблице нужно заменить английские буквы на русские. Иначе не будет работать.
МатросНаЗебре написал: Заполнит полные расстояния, не середины отрезков.
А чтобы найти расстояние до середины как лучше сделать? на ум приходит ввести в каждый отрезок промежуточные точки и увеличить область захвата в вашем коде ИЛИ есть более рациональные варианты?
у вновь поделенных отрезков появятся свои середины но выход есть - найти середины вновь поделенных... и не останавливаться на этом а вообще лучший вариант - обьяснить что за задачу решаем
потому что стандартная задача звучит так: есть некоторое множество точек соединенных между собой некоторым количеством линий. каждая линия имеет свою цену задача: найти такой маршрут из точки А в точку Б, чтобы цена перемещения по линиям была минимальной, а вы какую задачу решаете? кстати на данном графике есть замечательный пример, что кратчайший (самый дешевый) путь из 3 в 6 (или наоборот из 6 в 3), это не путь из 3 в 6 где цена = 32. а путь 3-А-6, цена = 31 этот пример отлично отображает суть задачи. а вы какую решаете?
Dim dic1 As Object
Dim dicA As Object
Sub GetPair()
Set dic1 = GetOneNodLength
Dim dic2 As Object
Dim b As String
Dim c As String
Dim v1 As Variant
Dim v2 As Variant
Dim v3 As Variant
Dim bRun As Boolean
Dim dic1Count As Long
Do
bRun = False
For Each v1 In dic1.keys
Set dic2 = dic1(v1)
dic1Count = dic2.Count
For Each v2 In dic2.keys
b = Split(v2, "-")(1)
For Each v3 In dic1(b).keys
c = Split(v3, "-")(1)
If Not dic1(v1).Exists(v1 & "-" & c) Then
dic1(v1)(v1 & "-" & c) = dic1(v1).Item(v2) + dic1(b).Item(v3) 'Длина пути
dicA(v1)(v1 & "-" & c) = dicA(v1).Item(v2) & "-" & Mid(dicA(b).Item(v3), Len(b) + 2) 'А-Б
End If
If dic1(v1)(v1 & "-" & c) > dic1(v1).Item(v2) + dic1(b).Item(v3) Then
dic1(v1)(v1 & "-" & c) = dic1(v1).Item(v2) + dic1(b).Item(v3) 'Длина пути
dicA(v1)(v1 & "-" & c) = dicA(v1).Item(v2) & "-" & Mid(dicA(b).Item(v3), Len(b) + 2) 'А-Б
End If
Next
Next
If dic1Count <> dic2.Count Then
bRun = True
End If
Next
OutputDic
If Not bRun Then Exit Do
Loop
End Sub
Function GetOneNodLength() As Object
Dim y As Long
y = Cells(Rows.Count, 1).End(xlUp).Row
Dim a As Variant
a = Range(Cells(4, 1), Cells(y, 3))
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Set dicA = CreateObject("Scripting.Dictionary")
Dim v As Variant
Dim i As Variant
For y = 1 To UBound(a, 1)
v = Split(a(y, 1), "-")
For i = 0 To 1
If Not dic.Exists(v(i)) Then
Set dic(v(i)) = CreateObject("Scripting.Dictionary")
Set dicA(v(i)) = CreateObject("Scripting.Dictionary")
End If
dic(v(i))(v(i) & "-" & v(1 - i)) = a(y, 3)
dic(v(i))(v(i) & "-" & v(i)) = 0
'А-Б
dicA(v(i))(v(i) & "-" & v(1 - i)) = v(i) & "-" & v(1 - i)
dicA(v(i))(v(i) & "-" & v(i)) = v(i) & "-" & v(i)
Next
Next
Set GetOneNodLength = dic
End Function
Private Sub OutputDic()
Dim y As Integer
Dim x As Integer
Dim y0 As Integer
Dim x0 As Integer
Dim s As String
Dim p As String
'Начало вывода
Dim rOut As Range
Set rOut = Range("F2")
y0 = rOut.Row
x0 = rOut.Column
y = y0
Do
y = y + 1
If Cells(y, x0) = "" Then Exit Do
Loop
Dim aHead As Variant
aHead = Range(Cells(y0 + 1, x0), Cells(y, x0))
Dim aOut As Variant
ReDim aOut(1 To y, 1 To y)
Dim aOuA As Variant
ReDim aOuA(1 To y, 1 To y)
For y = 1 To UBound(aHead, 1)
For x = 1 To UBound(aHead, 1)
s = aHead(x, 1)
p = aHead(y, 1)
If dic1.Exists(s) Then
If dic1(s).Exists(s & "-" & p) Then
aOut(y, x) = dic1(s)(s & "-" & p)
aOuA(y, x) = dicA(s)(s & "-" & p)
End If
End If
Next
Next
With rOut.Cells(2, 2).Resize(y, y)
.ClearContents
.Cells = aOut
End With
'А-Б. Вывод справа через какие точки проходит маршрут.
With rOut.Cells(2, 2 + 50).Resize(y, y)
.NumberFormat = "@"
.ClearContents
.Cells = aOuA
End With
End Sub
Ігор Гончаренко написал: у вновь поделенных отрезков появятся свои середины
Для этих отрезков нам и надо найти расстояние (не до самих вершин) а до середин между этими вершинами
Цитата
Ігор Гончаренко написал: потому что стандартная задача звучит так:
Да задача очень похожая. Отличие только в нахождении не вершин а центров. Поэтому ваш пример про путь 3-6 будет решаться по другому и самый кратчайший будет за 3-6 =32/2=16 против 3-А-6 = 14+17/2 = 23
МатросНаЗебре написал: Прикрепленные файлы Найти кратчайший путь.xlsm (58.5 КБ)
А не объясните как он берет данные? а то не могу (еще) прочесть этот код. вопрос в том (как понял он берет с столбца "C" исходники и вставляет в большую таблицу) Если я добавлю еще исходных данные в столбец "C" (увеличится по высоте) то заберет ли весь код их? и вставит в расширенную таблицу с полученными данными новое решение?
И как можно было бы сделать чтоб при новой таблице он выводил в левую столбец "В"нужные расстояние от нужного пункта отправления в ячейке "C1" Конечно не зная код это могу сделать через формулы, Но может есть более гуманный способ это вытащить?
bebbege2019 написал: Если я добавлю еще исходных данные в столбец "C" (увеличится по высоте) то заберет ли весь код их?
Код их обработает. Но в таблицу слева новые пункты нужно добавить самостоятельно. В прикреплённом примере я добавил пункты Ф и Я, чтоб было понятно, как добавляются новые пункты. Код читает данные до последней непустой ячейки в столбце А. Выводит данные до первой пустой ячейки в столбце F или строке 2.
Добавил вывод. Теперь в столбец В выводятся расстояния до отрезка от точки из ячейки С1.
И возможно пригодится. В ячейке ВС1 выводятся точки маршрута.