时间戳

首页 > 解决方案 > 如何在 VBA 中制作名称搜索功能？

excel - 如何在 VBA 中制作名称搜索功能？

问题描述

我有一个 Excel 文件，它允许我通过指定目标城市所在的国家/地区来计算两个城市之间的距离，以便它在正确的国家/地区进行搜索，并避免在不同国家/地区使用相同的城市名称出错。

我注意到一个问题是

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 = "&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

标签： excelvba

解决方案

改进城市名称搜索-

您的代码使用具有一些特殊性的法国网站的结果。对数据库中的拼写进行一些修改，可以通过 url request 找到城市（至少大多数城市）。

最典型的更正可以通过帮助功能解决correct()：

  • 该网站对一些城市使用法语拼写，例如 ROMA ~~> Rome
  • Marseille 11必须删除额外的数字区后缀
  • 必须用连接部分字符串的连字符替换空格 -
  • 单曲l或d在人声添加撇号之前'
  • 所有重音符号都必须替换为基本字符。

将主子中的URL分配更改为

   Url = DIST1 & Data(i, 1) & DIST2 & correct(Data(i, 2)) & "%20" & 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

请注意，上述功能仅涵盖最典型的情况，因此需要进一步补充。

玩得开心 / Beaucoup de plaisir :-)

推荐阅读