Entfernungen mit VBA und google berechnen
20.05.2014 12:28:00
VBA-Mieze
ich habe folgendes Problem und Google schob seit mehreren Stunden nach einer Lösung. Mittlerweile habe ich mehrere Codes ausprobiert, was aber zu keinem Erfolg führte.
Ich möchte in Excel über einen VBA Code die Entfernung zweier Orte berechnen. Dies soll am besten nur Anhand der Postleitzahlen funktionieren und muss nur für Deutschland funktionieren. Die Entfernung soll nicht durch klicken auf einen Commandbutton o.ä. errechnet werden, sondern über eine Formel (Zum Beispiel "=Entfernung(A1,A2)
Beispiel:
Zelle A1 = Start
Zelle A2 = Zielort
Zelle A3 = Entfernung
Dazu habe ich dieses Makro gefunden, was mir am passendsten erscheint. Es kommt aber immer nur der Fehlerwert -999als Ergebnis raus. Kann hier jemand helfen?
Besten Dank im Voraus
Die VBA-Mieze
Public Function Entfernung(ByVal von As String, ByVal nach As String) As Double
' V2 vom 18.06.2011
' Ermittlung der Entfernung zwischen zwei Adressen mit Hilfe von maps.google.de (kml-Output)
' von: Google-Maps Adressbeschreibung des Starts, z. B. "Germany,Berlin"
' nach: Google-Maps Adressbeschreibung des Ziels, z. B. "France,Paris"
' Rückgabe ist dann die Entfernung laut Google in Kilometern
Dim google As String
Dim dok As Object 'New DOMDocument
Dim knoten As Object 'IXMLDOMNodeList
Dim k As Object 'IXMLDOMNode
Set dok = CreateObject("MSXML.DOMDocument")
google = "http://maps.google.de/maps?hl=de&tab=ll&output=kml&saddr={0}&daddr={1}"
dok.async = False
von = Replace(von, " ", "%20")
nach = Replace(nach, " ", "%20")
dok.Load (Replace(Replace(google, "{0}", von), "{1}", nach))
If Not (dok Is Nothing) Then
' dok.setProperty "SelectionLanguage", "XPath"
dok.setProperty "SelectionNamespaces", "xmlns:kml='http://earth.google.com/kml/2.0'" ' Wichtig! _
Sonst klappt SelectNodes nicht.
On Error Resume Next
Set knoten = dok.DocumentElement.SelectNodes("//kml:Placemark/kml:name[text()='Route']")
If Err.number 0 Then
Entfernung = Fehler ' Als Fehlernummer
Exit Function
End If
On Error GoTo 0
For Each k In knoten
Dim Beschreibung As String
Beschreibung = k.ParentNode.SelectSingleNode("kml:description").Text
' HTML-Entity-Konstante für nbsp entfernen
Beschreibung = Replace(Beschreibung, "Entfernung: ", "")
' Zahlen und Komma zwischen Doppelpunkt und km sind die Entfernung
Beschreibung = Left(Beschreibung, InStr(1, Beschreibung, "&") - 1)
'beschreibung = Right(beschreibung, Len(beschreibung) - InStr(1, beschreibung, ":"))
'beschreibung = Right(beschreibung, Len(beschreibung) - InStr(1, beschreibung, "&"))
Entfernung = CDbl(Beschreibung)
Next
Set knoten = Nothing
End If
Set dok = Nothing
End Function