Блог

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

Я заметил, что проблема в том, что

• иногда он не находит определенные города, особенно во Франции, и поэтому 663 km каждый раз ставит «», потому что он ищет только « FR «.
• и для некоторых городов, таких как Рим или Париж и Марсель, он ничего не находит. Для Рима это также связано с правописанием ( Roma ), а для Парижа и Марселя — потому, что добавленный номер района не учитывается:

 City of departure   City of destination Destination country code    Distance (km)   Correct names
Soorts-Hossegor      PONT L ABBE         FR                        663              Pont-l'Abbé
Soorts-Hossegor      PONT L ABBE         FR                        663              Dolus-D'Oléron
Soorts-Hossegor      DOLUS D OLERON      FR                        663              Saint-Pierre-d'Oléron
Soorts-Hossegor      PONT L ABBE         FR                        663              Rome
Soorts-Hossegor      DOLUS D OLERON      FR                        663              Paris
Soorts-Hossegor      ST PIERRE D OLERON  FR                        663              Marseille
Soorts-Hossegor      NAPLES              IT                        1740
Soorts-Hossegor      ST PIERRE D OLERON  FR                        663
Soorts-Hossegor      DAX                 FR                        40
Soorts-Hossegor      ST PIERRE D OLERON  FR                        663
Soorts-Hossegor      PONT L ABBE         FR                        663
Soorts-Hossegor      BREST               FR                        817
Soorts-Hossegor      ST PIERRE D OLERON  FR                        663
Soorts-Hossegor      PONT L ABBE         FR                        663
Soorts-Hossegor      ST PIERRE D OLERON  FR                        663
Soorts-Hossegor      ST JEAN D AULPS     FR                        663
Soorts-Hossegor      ROMA TRIGORIA       IT                        
Soorts-Hossegor      PARIS 11            FR  
Soorts-Hossegor      MARSEILLE 03        FR                      
 

Я добавил в свой файл столбец с названиями проблемных городов, написанными правильно.

Я хотел бы знать, возможно ли, запустив мой скрипт, выполнить поиск в этом столбце и исправить города, которые вызывают проблемы? Этот последний столбец может быть изменен по мере того, как я нахожу названия городов, которые вызывают проблемы.

 Option Explicit

Sub Distance()
    
    Const DIST1 As String = "http://www.distance2villes.com/recherche?source="
    Const DIST2 As String = "amp;destination="
    Const DIST3 As String = "distanciaRuta"
    Const wsName As String = "Feuil1"
    
    'Dim w As Object: Set w = CreateObject("WINHTTP.WinHTTPRequest.5.1")
    Dim w As Object: Set w = CreateObject("MSXML2.XMLHTTP")
    Dim h As Object: Set h = CreateObject("htmlfile")
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(wsName)
    Dim rg As Range
    Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(, 2))
    Dim Data As Variant: Data = rg.Value
    
    Dim isFound As Boolean: isFound = True
    Dim i As Long
    Dim Url As String
    Dim S As String
    
    For i = 1 To UBound(Data, 1)
        If Len(Data(i, 1)) > 0 And Len(Data(i, 2)) > 0 Then
            Url = DIST1 amp; Data(i, 1) amp; DIST2 amp; Data(i, 2) amp; " " amp; Data(i, 3)
            w.Open "GET", Url, False
            w.Send
            h.body.innerHTML = w.responseText
            On Error GoTo NotFoundError
            S = h.getElementById(DIST3).innerText
            On Error GoTo 0
            If isFound Then
                Data(i, 1) = Replace(Left(S, Len(S) - 3), ",", "")
            Else
                Data(i, 1) = ""
                isFound = True
            End If
        Else
            Data(i, 1) = ""
        End If
    Next
    rg.Columns(1).Offset(, 3).Value = Data
    
    Exit Sub

NotFoundError:
    isFound = False
    Resume Next

End Sub
 

Улучшить поиск по названию города —

Ваш код использует результаты французского сайта с некоторыми особенностями. Внесение некоторых изменений в написание в вашей базе данных позволяет находить города (по крайней мере, большинство из них) с помощью запроса URL.

Наиболее типичные исправления могут быть устранены с помощью справочной функции correct() :

• сайт использует французское написание для некоторых городов, таких как РОМА ~~> Рим
• дополнительные числовые районные суффиксы, такие как Marseille 11 , должны быть удалены
• пробелы должны быть заменены дефисами - , соединяющими частичные строки
• сингл l или d перед вокалом добавляется апостроф '
• все акценты должны быть заменены базовым символом.

Измените назначение URL-адреса в главном подразделении на

    Url = DIST1 amp; Data(i, 1) amp; DIST2 amp; correct(Data(i, 2)) amp; " " amp; Data(i, 3)

 

вызов справочной функции correct() :

 
Function correct(ByVal city As String) As String
    Dim i As Long
    'a) change special cities to French spelling
    Dim cities: cities = Split("Roma,Wien", ",")
    Dim cities2: cities2 = Split("Rome,Vienne", ",")
    For i = 0 To UBound(cities)
        city = Replace(city, cities(i), cities2(i))
    Next
    'b)remove numeric district suffixes
    Dim tmp: tmp = Split(city, " ")
    If IsNumeric(tmp(UBound(tmp))) Then
        tmp(UBound(tmp)) = "DELETE"
        city = Join(Filter(tmp, "DELETE", False))
    End If
    'c) insert hyphens and apostrophs
    city = Replace(Replace(Replace(UCase(city), " L ", " L'"), " D ", " D'"), " ", "-")
    'd) remove all accents
    Dim chars:     chars = Split("Á À Â Ç É È Ê Î Ï")
    Dim chars2: chars2 = Split("A A A C E E E I I")
    For i = 0 To UBound(chars)
        city = Replace(city, chars(i), chars2(i))
    Next
    'e) return function result
    correct = city
End Function

 

Обратите внимание, что приведенные выше функции охватывают только наиболее типичные случаи, поэтому нуждаются в дополнительных дополнениях.

Have fun / Beaucoup de plaisir 🙂