Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1496to1500
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

Fahrkilometer ermitteln per Google

Fahrkilometer ermitteln per Google
13.06.2016 13:31:24
Jens
Hallo
anbei eine Datei mit man aus Google Entfernungskilometer ermitteln kann (erstes tabellenblatt)
Im zweiten Tabellenblatt sollte dasselbe gemacht werden nur insgesamt stehen Ziel und Anfang nicht mehr in einer Zeile sondern Zeile und Spalte .
Kann mit jemand helfen den Code entsprechend anzupassen?
https://www.herber.de/bbs/user/106195.xlsm

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Fahrkilometer ermitteln per Google
13.06.2016 13:32:44
Jens
zur Ergänzung.
Das Ganze sollte aber nach unten und rechts erweiterbar sein.
Sprich bis zur letzten beschriebenen Zeile bzw Spalte sollte das Makro ausgeführt werden.

AW: Fahrkilometer ermitteln per Google
13.06.2016 15:38:41
Michael
Hi Jens,
ich lade alles mal in ein Array und durchlaufe dieses:
Option Explicit
Private Sub CommandButton1_Click()
'Variablendeklarastionen
'Objekt - Late Binding
Dim objXML As Object 'fuer XML-"String"
Dim xmlDoc As Object
Dim xmlNod As Object
Dim z&, s&, maxz&, maxs&  ' Zeile, Spalte &=as long
Dim a As Variant
'Objekt - Early Binding
'Dim xmlDoc As New MSXML2.DOMDocument
'Dim xmlNod As MSXML2.IXMLDOMNode
'String
Dim strOAddr$, strDAddr
'On Error GoTo errorhandler
'XML-Objecte instanzieren
Set objXML = CreateObject("Msxml2.XMLHTTP")
'Wenn Instanzierung nichts gebracht hat, dann raus
If objXML Is Nothing Then MsgBox "msxml2-Fehler": Exit Sub
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
maxz = Range("A" & Rows.Count).End(xlUp).Row
maxs = Cells(1, Columns.Count).End(xlToLeft).Column
a = Range("A1").Resize(maxz, maxs)
For z = 2 To maxz
If InStr(a(z, 1), ",")  6 Then
a(z, 2) = "PLZ?"
Else
strOAddr = "Deutschland, " & a(z, 1)
For s = 2 To maxs
If InStr(a(1, s), ",")  6 Then
a(z, 2) = "PLZ?"
Else
strDAddr = "Deutschland, " & a(1, s)
objXML.Open "POST", _
"http://maps.googleapis.com/maps/api/" & _
"distancematrix/xml?origins=" & strOAddr & _
"&destinations=" & strDAddr & _
"&language=de-DE&sensor=false", False
objXML.setRequestHeader "Content-Type", _
"content=text/html; charset=UTF-8"
objXML.send
xmlDoc.LoadXML objXML.responseText
Set xmlNod = xmlDoc.SelectSingleNode _
("//row/element/distance/value")
If Not xmlNod Is Nothing Then
a(z, s) = Val(xmlNod.Text) / 1000
Else
a(z, s) = "n.v."
End If
End If
Next
End If
Next
Range("A1").Resize(maxz, maxs) = a
Err.Clear
'Fehlerbehandlung / Programmende
errorhandler:
'Wenn Fehlernummer  0, dann Ausgabe Fehlermeldung
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
'XML-Objecte zuruecksetzen
Set xmlNod = Nothing
Set xmlDoc = Nothing
Set objXML = Nothing
End Sub
Allerdings stelle ich fest, daß das Ding anscheinend Probleme mit Umlauten hat: irgendeine Anschrift in Regensburg geht, in Nürnberg nicht.
Schöne Grüße,
Michael

Anzeige
AW: Fahrkilometer ermitteln per Google
13.06.2016 14:47:40
UweD
Hallo
das ginge so...
- Rechtsclick auf den Tabellenblattreiter (Tabelle2)
- Code anzeigen
- Diesen Code dort reinkopieren

Private Sub CommandButton1_Click()' anderer Button
'Variablendeklarastionen
'Objekt - Late Binding
Dim objXML As Object 'fuer XML-"String"
Dim xmlDoc As Object
Dim xmlNod As Object
Dim iRow As Integer
Dim iCol As Integer
Dim iLR As Integer
Dim iLC As Integer
'Objekt - Early Binding
'Dim xmlDoc As New MSXML2.DOMDocument
'Dim xmlNod As MSXML2.IXMLDOMNode
'String
Dim strOAddr$, strDAddr
On Error GoTo errorhandler
'XML-Objecte instanzieren
Set objXML = CreateObject("Msxml2.XMLHTTP")
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
iLR = Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte A
iLC = Cells(1, Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile 1
For iRow = 2 To iLR
For iCol = 2 To iLC
'Wenn Instanzierung nicht nichts gebracht hat, dann
If Not objXML Is Nothing Then
'OriginAddress ermitteln
'Hinweise:
'PLZ auch 4stellig moeglich
strOAddr = "Deutschland, " & Format(Cells(iRow, 1), "0####")
'DestinationAddress ermitteln
'Hinweise:
'PLZ nicht 4stellig moeglich!
strDAddr = "Deutschland, " & Format(Cells(1, iCol), "0####")
'Abfrage oeffnen
objXML.Open "POST", "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" &  _
strOAddr & "&destinations=" & strDAddr & "&language=de-DE&sensor=false", False
'Abfrageheader
objXML.setRequestHeader "Content-Type", "content=text/html; charset=UTF-8"
'Abfrage senden
objXML.send
'Abfrageergebnis (Text) aufnehmen
xmlDoc.LoadXML objXML.responseText
'Zeit auslesen /Value=Sekunden /Text = Minuten mit Angabe "Minuten"
'*nicht benötigt Set xmlNod = xmlDoc.SelectSingleNode("//row/element/duration/ _
value")
'Zeit in Stundenzelle eintragen, Rueckgabewert / 86400
'*nicht benötigt Cells(iRow, 3) = CDate(xmlNod.Text / 86400)
'Entfernung auslesen /Value=Meter /Text = Kilometer mit Angabe "km"
Set xmlNod = xmlDoc.SelectSingleNode("//row/element/distance/value")
'Entfernung in km zelle eintragen, Rueckgabewert / 1000
Cells(iRow, iCol) = xmlNod.Text / 1000
'Ende Wenn Instanzierung nicht nichts gebracht hat, dann
End If
Next iCol
Next iRow
Err.Clear
'Fehlerbehandlung / Programmende
errorhandler:
'Wenn Fehlernummer  0, dann Ausgabe Fehlermeldung
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
'XML-Objecte zuruecksetzen
Set xmlNod = Nothing
Set xmlDoc = Nothing
Set objXML = Nothing
End Sub

Gruß UweD
Über Rückmeldungen würde ich mich freuen

Anzeige
AW: Fahrkilometer ermitteln per Google
13.06.2016 15:14:26
Jens
Hey super Danke.
Kann man den Code noch irgendwie so erweitern, dass pro Zeile die kleinste Kilometer Angabe grün (zelle) hinterlegt wird und pro Spalte die kleinste Kilometer gelb (zelle) hinterlegt wird.
Dann wäre es perfekt da auch eine Hilfe zur Übersichtlichkeit geschaffen wäre.

@Uwe
13.06.2016 15:40:17
Michael
Hi,
habe Deine Antwort übersehen, sorry.
Schöne Grüße,
Michael

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige