Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1816to1820
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Excel Code Entfernung berechnen

Excel Code Entfernung berechnen
12.03.2021 14:24:02
Hannser
Hallo, ich habe bisher mit dem Code gearbeitet. Leoder klappt das nicht mehr bei der Ausgabe kommt immer der Fehler #Wert!
Kann mir jemand sagen was sich geändert haben soll?
A1= Hannover
B1 = Berlin
C1 = Entfernung("Deutschland," & A1;"Deutschland," & B1)

Public Function Entfernung(ByVal von As String, ByVal nach As String, Optional iTyp As Integer = _
_
_
_
_
0) As Variant
' V2 vom 18.06.2011
' V2.1 vom 15.10.2011 (EtoPHG) Km & Reisezeit
' 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"
' Parameter iTyp=0 = Rückgabe ist dann die Entfernung laut Google in Kilometern
'           iTyp=1 = Rückgabe ist dann ca. Reisezeit laut Google
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.
Set knoten = dok.DocumentElement.SelectNodes("//kml:Placemark/kml:name[text()='Route']") _
_
_
_
_
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: ", "")
Select Case iTyp
Case 0
' Zahlen und Komma zwischen Doppelpunkt und km sind die Entfernung
beschreibung = Left(beschreibung, InStr(1, beschreibung, "&") - 1)
Entfernung = CDbl(beschreibung)
Case 1
'Text in (Klammern) ist die Reisezeit
Entfernung = Split(Split(beschreibung, "(")(1), ")")(0)
End Select
Next
Set knoten = Nothing
End If
Set dok = Nothing
End Function


2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel Code Entfernung berechnen
12.03.2021 15:59:40
volti
Hallo,
leider kann ich Dir bei Deinem Problem jetzt nicht helfen.
AberFalls es gar nicht mehr gehen sollte, hier eine Alternative, die Lufttrecken- und Fahrstreckendaten holt:
Code:

Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Type DIST_STRUCT
     Start As String ' Mehrere durch "/" getrennt eingeben
     Ziel  As String
     LDist As String
     FDist As String
     LTime As String
     FTime As String
End Type
Private Sub EntfernungErmitteln()
Dim tDist As DIST_STRUCT
Dim WS As Worksheet
Set WS = Worksheets("Tabelle1")
With tDist
    .Start = WS.Range("B3").Value
    .Ziel = WS.Range("C3").Value
    GetDistance tDist
    WS.Range("E3").Value = .FDist
    WS.Range("G3").Value = .LDist
    WS.Range("F3").Value = .FTime
    WS.Range("H3").Value = .LTime
End With
End Sub
Private Sub GetDistance(tDist As DIST_STRUCT)
' Get-Methode
Dim oDoc As Object, i As Integer
With CreateObject("InternetExplorer.Application")
    '.Visible = True
    .Navigate "http://www.luftlinie.org/" _
    & tDist.Start & "/" & tDist.Ziel          ' Zur Url surfen
    While Not .readyState = 4: DoEvents: Wend ' Warten bis Seite geladen ist
    On Error Resume Next
    Set oDoc = .Document
    With tDist
        If Not .Start Like "#####*" Then .Start = ""
        If Not .Ziel Like "#####*" Then .Ziel = ""
        Do
           Sleep 100: i = i + 1
           .FDist = oDoc.getElementById("strck").outertext
           If Not .FDist Like "*--*" Then Exit Do
           If i > 50 Then Exit Do
        Loop
        .LDist = oDoc.getElementsByClassName("value km")(0).outertext & " km"
        .LTime = oDoc.getElementsByClassName("directionsResultTime0")(0).outertext
        .FTime = oDoc.getElementsByClassName("directionsResultTimeTotal")(0).outertext
        .Start = Trim$(.Start & " " & oDoc.getElementsByClassName("regions")(0).outertext)
        .Ziel = Trim$(.Ziel & " " & oDoc.getElementsByClassName("regions")(2).outertext)
    End With
    .Quit    ' IE schließen
End With
End Sub

_________
viele Grüße
Karl-Heinz

Anzeige

8 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige