Визуализация движения по маршруту

Предположим, что перед нами стоит классическая задача транспортной логистики: визуализировать движение некоего объекта по заданному маршруту из нескольких промежуточных точек. Для конкретики, давайте возьмем скорый фирменный поезд "Жигули", движущийся по маршруту Москва - Самара по следующему графику (взято из Яндекс.Расписаний):

Расписание поезда

Для решения задачи нам потребуется Excel 2013-2016 с установленной надстройкой Power Map. В Excel 2016 она установлена по умолчанию, для Excel 2013 можно скачать ее бесплатную превью-версию.

Этап 1. Находим координаты

Для однозначной привязки к промежуточным пунктам маршрута лучше использовать не названия населенных пунктов (они могут повторяться либо отсутствовать в принципе в нужном месте), а нормальные географические координаты. Достаточно щелкнуть по нужному месту в Яндекс-картах или Google Maps и вы увидите широту и долготу этой точки:

Находим координаты

Добавим найденные координаты к нашей исходной таблице расписания движения поезда:

Исходные данные

Этап 2. Дробим перегоны

Для плавного отображения движения поезда на карте нам необходимо разделить каждый перегон на несколько участков (чем их больше, тем плавнее будет анимация). Таким образом, перед нами встает задача получить примерные координаты и время для каждой промежуточной точки. Решить проблему можно формулой либо макросом.

Например, если хотим разбить каждый перегон на шесть интервалов (т.е. пять точек), то можно реализовать все одной формулой:

Деление перегона на фрагменты формулой

Но вставлять промежуточные строки, вводить и копировать формулу на все зеленые ячейки для каждого перегона придется вручную.

Другой вариант - макрос, что гораздо удобнее при большом количестве перегонов и промежуточных точек маршрута. Откройте редактор Visual Basic на вкладке Разработчик (Developer) или нажмите сочетание клавиш Alt+F11. Вставьте в вашу книгу новый пустой модуль через меню Insert - Module и скопируйте туда этот код:

Sub MakeRouteTable()
Dim DeltaT#, DeltaS#, DeltaD#, NumSteps%, FirstRow%, LastRow%
Const MINS_IN_ONE_STEP = 1

Application.ScreenUpdating = False

FirstRow = ActiveCell.CurrentRegion.Rows(3).Row
LastRow = ActiveCell.CurrentRegion.Rows.Count + FirstRow - 3
For i = 6 To 3 Step -1
    'определяем число шагов на перегоне
    NumSteps = Int((Cells(i, 2) - Cells(i - 1, 2)) * 24 * 60 / MINS_IN_ONE_STEP)
    'вычисляем изменение координат и времени на каждом шаге
    DeltaT = (Cells(i, 2) - Cells(i - 1, 2)) / (NumSteps + 1)
    DeltaS = (Cells(i, 3) - Cells(i - 1, 3)) / (NumSteps + 1)
    DeltaD = (Cells(i, 4) - Cells(i - 1, 4)) / (NumSteps + 1)
    'заполняем строки интервалов по каждому перегону
    For j = 1 To NumSteps
        Rows(i).Insert
        Cells(i, 2) = Cells(i + 1, 2) - DeltaT
        Cells(i, 3) = Cells(i + 1, 3) - DeltaS
        Cells(i, 4) = Cells(i + 1, 4) - DeltaD
    Next j
Next i

Как легко сообразить, константа MINS_IN_ONE_STEP задает количество минут в каждом шаге - можете менять ее значение по своему усмотрению. Теперь если выделить таблицу с данными или установить в нее активную ячейку, а потом запустить наш макрос сочетанием клавиш Alt+F8 или кнопкой Макросы на вкладке Разработчик (Developer - Macros), то наша таблица будет преобразована в следующий вид:

Таблица после деления макросом

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

Этап 3. Переходим к карте

Осталось совсем чуть-чуть. Выделите полученную таблицу и на вкладке Вставка нажмите кнопку 3D-карта (Insert - 3D-map):

Кнопка 3D-карт

Не перепутайте ее с кнопкой Карты (которая с глобусом) или Карты Bing (желтого цвета). После нажатия должно открыться окно надстройки Power Map. 

В правой части окна на панели добавьте в группе Расположение (Location) поля широты и долготы и выберите напротив каждого название соответствующего столбца из нашей таблицы. Если все сделаете правильно, то на карте тут же должен отобразиться наш маршрут:

Маршрут в окне 3D Maps

Теперь осталось выбрать в выпадающем списке Время (Time) столбец со значениями даты-времени из нашей таблицы и можно запускать анимацию с помощью кнопки воспроизведения в нижней части окна:

Анимация движения поезда

Дополнительно можно поиграться настройками слоя - кнопка Параметры слоя (Layer Options) в правом нижнем углу - и установить цвет, размер, прозрачность и т.д. отображаемых точек.

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

При щелчке левой кнопкой мыши по любой интересующей точке маршрута мы увидим ее подробные данные - координаты и время прохождения:

Подробности по точке

Этап 4. Несколько поездов сразу

Не секрет, что на самом деле по маршруту Москва-Самара курсируют два состава - в противофазе: когда один стартует из Москвы, другой примерно в то же время начинает движение ему навстречу из Самары. Утром один из них приходит в Самару, а другой, соответственно, в Москву и вечером процесс запускается заново. Расписание второго примерно отзеркаливает первый:

Встречный состав

Что сделать, чтобы отобразить их на карте оба сразу?

Если по маршруту одновременно движется больше одного объекта, то данные по ним можно обработать аналогичным образом (Этапы 1 и 2) и просто добавить в продолжение нашей маршутной таблицы. А чтобы отличать поезда друг от друга, добавить еще один столбец с названием объекта:

Продолжение таблицы

Теперь, если построить по такой таблице еще одну визуализацию, мы будем видеть движение двух составов одновременно:

Анимация движения двух составов

Красота :)

Ссылки по теме




28.05.2017 20:50:04
Добрый день
Николай,-очень кстати данная тема, работа связана с транспортом и маршрутами,давно ждал что то подобное.Огромное Вам спасибо
29.05.2017 14:59:35
Просто прекрасная и нужная инструкция. Николай, коллеги, а подскажите, пожалуйста, какой модуль к MS Office должен быть подключен для того, чтобы было доступно:

Вставка  ---> нажмите кнопку 3D-карта (Insert - 3D-map):
02.06.2017 09:35:05
"Для решения задачи нам потребуется Excel 2013-2016 с установленной надстройкой Power Map. В Excel 2016 она установлена по умолчанию, для Excel 2013 можно скачать ее бесплатную превью-версию."
29.05.2017 20:49:22
Спасибо за урок! Не сочтите за докапывание, но в конце 2 этапа "Как видите, каждый перегон теперь делится на несколько интервалов - по 1 секунде каждый." - по минуте же - не?
27.10.2017 10:39:55
Э.. да, конечно! Спасибо! :)
02.06.2017 14:53:02
спасибо
06.11.2017 14:55:30
Очень крутая тема !!!

Предлагаю развить на предмет расчета расстояния.
Подскажите пожалуйста как это возможно реализовать с помощью google map например?

У меня есть вот такой макрос, который рассчитывает расстояние, маршрут и время в пути. Мне необходима только та часть которая отвечает за измерение расстояния. Самостоятельно разобрать не хватает знаний. Буду признателен за помощь.

Option Explicit
Public ActivationMark As Boolean
Public WasRequestGoogle As Boolean
Public MyDistance As Variant
Public MyDuration As Variant

'Задаем границы допустимых координат
Public Const Lat_min = -180, Lat_max = 180
Public Const Lon_min = -180, Lon_max = 180

'Скрываем заставку
Private Sub KillTheForm()
  Unload Excelminsk
End Sub

Sub GetDistanceDurationGoogle(Address1 As String, Address2 As String)
   Dim XMLDoc As Object
   Dim Coord1NodeList As Object, Coord2NodeList As Object
   Dim DistanceNodeList As Object, DurationNodeList As Object
   Dim MyRequest As String
   Dim Lat1 As String, Lon1 As String, Lat2 As String, Lon2 As String

   On Error Resume Next
   
   'Обнуляем переменные
   MyDistance = ""
   MyDuration = ""
   
   'Ставим задержку между запросами
   If (Address1 = Range("A3";) And Address2 = Range("B3";)) Then
   Else
       Application.Wait (Now + TimeValue("0:00:01";))
   End If
   
   'Кодируем адрес
   Address1 = RussianStringToURLEncode_New(Address1)
   Address2 = RussianStringToURLEncode_New(Address2)
   MyRequest = "https://maps.googleapis.com/maps/api/directions/xml?origin=" & Address1 & "&destination=" & Address2 & "&mode=driving&language=ru"
   'Debug.Print MyRequest
   
   'Загружаем XML-документ
   Set XMLDoc = CreateObject("Msxml2.DOMDocument";)
   XMLDoc.async = False
   If Not XMLDoc.Load(MyRequest) = True Then
       MyDistance = "!ДАННЫЕ НЕ ЗАГРУЖЕНЫ"
       MyDuration = "!ДАННЫЕ НЕ ЗАГРУЖЕНЫ"
       Exit Sub
   End If
   
   'Считываем статус ответа
   Select Case XMLDoc.SelectNodes("*/status";).Item(0).text
       Case "OK"
       Case "NOT_FOUND"
           'Не нашел адрес точки
           MyDistance = "!НЕ НАШЕЛ АДРЕС"
           MyDuration = "!НЕ НАШЕЛ АДРЕС"
           Exit Sub
       Case "ZERO_RESULTS"
           'Не может проложить маршрут
           MyDistance = "!НЕТ ДОРОГИ"
           MyDuration = "!НЕТ ДОРОГИ"
           Exit Sub
       Case "OVER_QUERY_LIMIT"
           If WasRequestGoogle = False Then
               Application.Wait (Now + TimeValue("0:00:02";))
               WasRequestGoogle = True
               Call GetDistanceDurationGoogle(Address1, Address2)
               Exit Sub
           Else
               MyDistance = "!ПРЕВЫШЕНИЕ ЛИМИТА"
               MyDuration = "!ПРЕВЫШЕНИЕ ЛИМИТА"
               Exit Sub
           End If
       Case "REQUEST_DENIED"
           MyDistance = "!ЗАПРОС ОТКЛОНЕН"
           MyDuration = "!ЗАПРОС ОТКЛОНЕН"
           Exit Sub
       Case "INVALID_REQUEST"
           MyDistance = "!НЕВЕРНЫЙ ЗАПРОС"
           MyDuration = "!НЕВЕРНЫЙ ЗАПРОС"
           Exit Sub
       Case "UNKNOWN_ERROR"
           MyDistance = "!НЕИЗВЕСТНАЯ ОШИБКА"
           MyDuration = "!НЕИЗВЕСТНАЯ ОШИБКА"
           Exit Sub
   End Select
   
   'Получаем координаты
   Set Coord1NodeList = XMLDoc.SelectNodes("*//start_location";)
   Lat1 = Coord1NodeList.Item(Coord1NodeList.Length - 1).FirstChild.text
   Lon1 = Coord1NodeList.Item(Coord1NodeList.Length - 1).LastChild.text
   
   Set Coord2NodeList = XMLDoc.SelectNodes("*//end_location";)
   Lat2 = Coord2NodeList.Item(Coord2NodeList.Length - 1).FirstChild.text
   Lon2 = Coord2NodeList.Item(Coord2NodeList.Length - 1).LastChild.text
   
   'Debug.Print "Coord1=" & Lat1 & ", " & Lon1
   'Debug.Print "Coord2=" & Lat2 & ", " & Lon2
   
   'Проверяем ограничения для координат
   If MyValue(Lat1) < Lat_min Or MyValue(Lat1) > Lat_max Or MyValue(Lon1) < Lon_min Or MyValue(Lon1) > Lon_max Or _
      MyValue(Lat2) < Lat_min Or MyValue(Lat2) > Lat_max Or MyValue(Lon2) < Lon_min Or MyValue(Lon2) > Lon_max Then
       MyDistance = "!ОГРАНИЧЕНИЕ ДЕМО"
       MyDuration = "!ОГРАНИЧЕНИЕ ДЕМО"
   Else
       'Расстояние в метрах
       Set DistanceNodeList = XMLDoc.SelectNodes("*//distance";)
       MyDistance = Round(DistanceNodeList.Item(DistanceNodeList.Length - 1).FirstChild.text / 1000, 0)
       'Debug.Print "MyDistance=" & MyDistance
       
       'Время в секундах
       Set DurationNodeList = XMLDoc.SelectNodes("*//duration";)
       MyDuration = CLng(DurationNodeList.Item(DurationNodeList.Length - 1).FirstChild.text) / 3600 / 24
       'Debug.Print "MyDuration=" & MyDuration
   End If
   
   'Удаляем XML
   Set XMLDoc = Nothing
   Set Coord1NodeList = Nothing
   Set Coord2NodeList = Nothing
   Set DistanceNodeList = Nothing
   Set DurationNodeList = Nothing
   
   'Обнуляем счетчик повторных запросов
   WasRequestGoogle = False

End Sub
'Меняем адрес на понятный браузеру
Function RussianStringToURLEncode_New(ByVal txt As String) As String
   Dim i As Long
   Dim l As String, t As String

   For i = 1 To Len(txt)
       l = Mid(txt, i, 1)
       Select Case AscW(l)
           Case Is > 4095: t = "%" & Hex(AscW(l) \ 64 \ 64 + 224) & "%" & Hex(AscW(l) \ 64) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
           Case Is > 127: t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
           Case 32: t = "%20"
           Case Else: t = l
       End Select
       RussianStringToURLEncode_New = RussianStringToURLEncode_New & t
   Next
End Function
'Конвертируем широту и долготу из текста в число
Function MyValue(ByVal text As String) As Double
   Dim MySeparator As String
   'Считываем системный разделитель
   MySeparator = Application.International(xlDecimalSeparator)
   MyValue = (Trim(Replace(text, ".", MySeparator)) + 0)
End Function




Спасибо!!!!
Наверх