Get Google Maps XML data, parse it and input to Ex

2019-07-28 11:28发布

With help from Stackoverflow I managed to get a working solution for getting Google Maps XML data, parsing it and inputting to Excel cells. However my next intention get it working for several requests when there are 5 different locations to be analyzed and data from each XML should be inputted to different cells. I am able to do it by 5 different macros and then use like:

Sub Master()
   Call macro1
   Call macro2
   Call macro3
   Call macro4
   Call macro5
End Sub

I was thinking maybe I can make code faster by making just one macro and including all in there. Now I stuck with it. Maybe by including just two or three destination variants somebody can give me a hint how to proceed?

I have data on Worksheet "Other Data" (you can see first one working after running my current macro, API key is not fully displayed for reason):

enter image description here

Then I have tried to make them all work, but got stuck. I use DOMDocument30 because I would like this code to work in Excel 2013 as well. Here is my current macro:

Sub GoogleMapsAPIDurDist()
    Dim xmlhttp As Object
    Dim xmlhttp_1 As Object
    Dim xmlhttp_2 As Object
    Dim xmlhttp_3 As Object
    Dim xmlhttp_4 As Object
    Dim myurl As String
    Dim myurl_1 As String
    Dim myurl_2 As String
    Dim myurl_3 As String
    Dim myurl_4 As String
    Dim xmlDoc As DOMDocument30
    Dim xmlNode As IXMLDOMNode
    Dim sTemp As String
    Dim RE As Object, MC As Object
    Dim rDest As Range
    Dim APIkey As Range
    Dim TravelMode As Range

    Set xmlDoc = New DOMDocument30
    Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
    Set APIkey = ThisWorkbook.Worksheets("Other Data").Range("CE1")
    Set TravelMode = ThisWorkbook.Worksheets("Other Data").Range("BY3")

    myurl = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & ThisWorkbook.Worksheets("Other Data").Range("BY1").Value _
    & "&destinations=" & ThisWorkbook.Worksheets("Other Data").Range("BY2").Value & "&mode=" & TravelMode & "&key=" & APIkey

    myurl_1 = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & ThisWorkbook.Worksheets("Other Data").Range("BY5").Value _
    & "&destinations=" & ThisWorkbook.Worksheets("Other Data").Range("BY6").Value & "&mode=" & TravelMode & "&key=" & APIkey

    myurl_2 = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & ThisWorkbook.Worksheets("Other Data").Range("BY9").Value _
    & "&destinations=" & ThisWorkbook.Worksheets("Other Data").Range("BY10").Value & "&mode=" & TravelMode & "&key=" & APIkey

    myurl_3 = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & ThisWorkbook.Worksheets("Other Data").Range("BY13").Value _
    & "&destinations=" & ThisWorkbook.Worksheets("Other Data").Range("BY14").Value & "&mode=" & TravelMode & "&key=" & APIkey

    myurl_4 = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & ThisWorkbook.Worksheets("Other Data").Range("BY17").Value _
    & "&destinations=" & ThisWorkbook.Worksheets("Other Data").Range("BY18").Value & "&mode=" & TravelMode & "&key=" & APIkey

    xmlhttp.Open "GET", myurl, False

    'xmlhttp.Open "GET", myurl_1, False

    'xmlhttp.Open "GET", myurl_2, False

    'xmlhttp.Open "GET", myurl_3, False

    'xmlhttp.Open "GET", myurl_4, False
    xmlhttp.send

    'hard coded here.  Change to suit
    Set rDest = ThisWorkbook.Worksheets("Other Data").Range("CA2")

    xmlDoc.LoadXML xmlhttp.responseText
    Set xmlNode = xmlDoc.SelectSingleNode("//duration/text")


    sTemp = xmlNode.Text

    Set RE = CreateObject("vbscript.regexp")
    With RE
        .Global = True
        .Pattern = "\d+"
        If .test(sTemp) = True Then
            Set MC = .Execute(sTemp)
            rDest(0, 1) = MC(0) & "," & MC(1)
        End If
    End With


    Set xmlNode = xmlDoc.SelectSingleNode("//distance/text")
    sTemp = xmlNode.Text
    With RE
        If .test(sTemp) = True Then
            Set MC = .Execute(sTemp)
            rDest(1, 1) = MC(0)
        End If
    End With

End Sub

1条回答
Emotional °昔
2楼-- · 2019-07-28 11:54

Simply loop over your Excel cells with Step counter for every four cell block ranges. Also avoid the need of repeating the long ThisWorkbook.Worksheets("Other Data") by using a With block.

Also, your regex might not be needed. A simple nested Replace() (depending your language and distance units, e.g., km vs mi) can work with correct reference to cell ranges in CA column. Finally, adjust Dim and Set by early-binding methods. Of course too always uninitialize Set objects.

Sub GoogleMapsAPIDurDist()
    Dim xmlhttp As New MSXML2.serverXMLHTTP, xmlDoc As New DOMDocument30
    Dim myurl As String, sTemp As String
    Dim APIkey As Range, TravelMode As Range
    Dim i as Long                                                ' NEW VARIABLE

    With ThisWorkbook.Worksheets("Other Data")
         Set APIkey = .Range("CE1")
         Set TravelMode = .Range("BY3")

         For i = 1 to 17 Step 4                                  ' LOOP WITH STEP    
              myurl = "https://maps.googleapis.com/maps/api/distancematrix/xml?" _
                       & "origins=" & .Range("BY" & i).Value  _
                       & "&destinations=" & .Range("BY" & i + 1).Value _
                       & "&mode=" & TravelMode & "&key=" & APIkey   

              xmlhttp.Open "GET", myurl, False
              xmlhttp.send
              xmlDoc.LoadXML xmlhttp.responseText

              sTemp = xmlDoc.SelectSingleNode("//duration/text").Text
              .Range("CA" & i) = Replace(Replace(sTemp, "days", ", "), "hours", "")

              sTemp = xmlDoc.SelectSingleNode("//distance/text").Text
              .Range("CA" & i + 1) = Replace(Replace(sTemp, " km", ""), " ", ",")
         Next i
    End With

    Set APIkey = Nothing: Set TravelMode = Nothing
    Set xmlhttp = Nothing: Set xmlDoc = Nothing
End Sub
查看更多
登录 后发表回答