CODEWITHSUNDEEP
excelvba
Theo27
Theo27

Reputation: 405

How to make a name search function in VBA?

I have an Excel file that allows me to calculate the distances between two cities by specifying the country in which the destination city is located so that it searches in the right country and avoids making mistakes with the same city names in different countries.

I noticed a problem is that

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

I have added a column in my file with the names of the cities that are problematic, spelled correctly.

I would like to know if it is possible by running my script to search in this column and to correct the cities that cause problems? This last column could be changed as and when I find the names of cities that cause problems.

Option Explicit

Sub Distance()
    
    Const DIST1 As String = "http://www.distance2villes.com/recherche?source="
    Const DIST2 As String = "&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 & Data(i, 1) & DIST2 & Data(i, 2) & "%20" & 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

Upvotes: 2

Views: 516

Answers (1)

T.M.
T.M.

Reputation: 9948

Improve city name search -

Your code uses results of a French site with some pecularities. Making some modifications to the spelling in your data base allows to find cities (at least most of them) via url request .

The most typical corrections can be resolved via help function correct():

  • the site uses French spelling for some cities like ROMA ~~> Rome
  • additional numeric district suffixes like Marseille 11 have to be removed
  • blanks have to be replaced by hyphens - connecting partial strings
  • single l or d before vocals get added an apostrophe '
  • all accents have to be replaced by the base character.

Change your URL assignment in the main sub to

   Url = DIST1 & Data(i, 1) & DIST2 & correct(Data(i, 2)) & "%20" & Data(i, 3)

calling the help function 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

Note that the above functions only covers the most typical cases thus needing further additions.

Have fun / Beaucoup de plaisir :-)

Upvotes: 1

Related Questions