Anzeige
Archiv - Navigation
1652to1656
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

Entfernungsberechnung

Entfernungsberechnung
30.10.2018 20:41:12
Pit30
Guten Tag,
nachdem Google Entfernungsberechnung nur noch mit API Key gehen soll, brauche ich Hilfe in der Excel Anwendung. Den API Key habe ich mir bereits besorgt. In der Umsetzung in Excel komme ich als Logistiker mit VBA einfach nicht weiter. Obwohl es bereits Formeln im Forum gibt.
Der Excelaufbau einmal als Beispiel:
In Spalte A steht der Abgangsort
In Spalte B der Empfangsort
In Spalte C soll die Entfernung stehen
Spalte D Fahrzeit - nicht 100 % notwendig
Saplte E der Link zur Route- wenn möglich
Der Abruf der Entferung soll Zeile für Zeile möglich sein.
Kann mit jemand die Code einfügen. Denn API bringe ich dann schon noch rein :-)
https://www.herber.de/bbs/user/125016.xlsx
Vielen Dank.
mfg
Peter

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Die Dateien sind doch in den Foren bekannt ...
30.10.2018 20:48:31
lupo1
... wenn Du Google oberhalb eines Höchstvolumens dafür verwenden möchtest, wirst Du - "API-Key" hin uoder her - dafür zahlen müssen.
AW: Die Dateien sind doch in den Foren bekannt ...
31.10.2018 06:28:02
Pit30
Hallo,
pro Monat schätze ich auf 500 Ermittlungen. DAs können 10 pro Tag oder auch 100 sein.
Laut Google soll man pro Monat ein Guthaben von 200 € haben.
Wichtig ist das die Ermittlung Zeile für Zeile erfolgen kann, damit man eine Liste abarbeiten kann.
mfg
Peter
AW: Die Dateien sind doch in den Foren bekannt ...
31.10.2018 08:13:19
Oisse
Hallo Peter,
ich hab mal folgenden Code für mich auch aus dem I-net zusammengebastelt.
Allerdings kann es sein, wenn du ein langsames Internet hast, dass die Daten nicht schnell genug kommen und deshalb die ersten Distanzen fehlen, dann müsstest du die Zeit etwas erhöhen (ist im Code etwas weiter unten). Leider hab ich´s nicht hinbekommen, dass Excel mit dem nächsten Ort solange wartet, bis der Wert des vorherigen Ortes eingetroffen ist.
Aber ich denke man kann auch so ganz gut damit zurechtkommen.
Bei mir sind die Daten für die Orte in zwei verschiedenen Tabellen, deshalb müsstest du das halt auf deine Situation anpassen. Ich hoffe du kommst damit zurecht. Kopier den Code mal in ein allgemeines Modul.
Viel Freude damit.
Gruß Oisse

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub Entfernung()
'Variablendeklarationen
'Objekt - Late Binding
Dim objXML As Object 'fuer XML-"String"
Dim xmlDoc As Object
Dim xmlNod As Object
Dim wks_Tab As Worksheet
Dim wks_Uebersicht As Worksheet
Dim lzTab As Long
Dim i As Long
Dim e As Long
Dim Text As Variant
Dim Arr()
'Objekt - Early Binding
'Dim xmlDoc As New MSXML2.DOMDocument
'Dim xmlNod As MSXML2.IXMLDOMNode
'String
Dim strOAddr$, strDAddr
'Integer
'On Error GoTo Fehler
'On Error Resume Next
'Flackern aus
Application.ScreenUpdating = False
'XML-Objecte instanzieren
Set objXML = CreateObject("Msxml2.XMLHTTP")
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
Set wks_Tab = ThisWorkbook.Worksheets("Tabelle2")
Set wks_Uebersicht = ThisWorkbook.Worksheets("Uebersicht")
Set Meldung = CreateObject("WScript.Shell")
lzTab = wks_Tab.Cells(Rows.Count, 1).End(xlUp).Row
ReDim Arr(lzTab - 1, 1)
e = 0
'Wenn Instanzierung nicht nichts gebracht hat, dann
If Not objXML Is Nothing Then
'OriginAddress ermitteln
'Hinweise:
'PLZ auch 4stellig moeglich
strOAddr = Format(wks_Uebersicht.Cells(3, 2), "0####") & "," & ReplaceGermans( _
wks_Uebersicht.Cells(4, 2))
'Schleife ueber alle DestinationAddress
For i = 1 To lzTab
'DestinationAddress ermitteln
'Hinweise:
'PLZ nicht 4stellig moeglich!
strDAddr = Format(wks_Tab.Cells(i, 1), "0####") & "," & ReplaceGermans(wks_Tab.Cells(i,  _
2))
'Abfrage oeffnen
objXML.Open "GET", "https://maps.googleapis.com/maps/api/distancematrix/xml?units= _
metric&origins=" & strOAddr & ",germany&&destinations=" & strDAddr & ",germany&&language=de&key=AIzaSyA1LPwMrRq9773niDvPgJQeKbORchFFe0s"
'objXML.Open "POST", "https://maps.googleapis.com/maps/api/distancematrix/xml?origins="  _
& strOAddr & ",germany&&destinations=" & strDAddr & "Key = AIzaSyA1LPwMrRq9773niDvPgJQeKbORchFFe0s"
'objXML.Open "POST", "https://maps.googleapis.com/maps/api/distancematrix/json?units= _
metric&origins=" & strOAddr & "destinations=" & strDAddr & "&key=AIzaSyA1LPwMrRq9773niDvPgJQeKbORchFFe0s"
'Abfrageheader
objXML.setRequestHeader "Content-Type", "content=text/html; charset=UTF-8"
'Abfrage senden
objXML.send
'DoEvents
'Application.Wait (Now + TimeValue("0:00:2"))
'Abfrageergebnis (Text) aufnehmen
'MsgBox objXML.responseText
On Error Resume Next
Dim T As Double
T = Timer + 1 'länge der Wartezeit in Sekunden
Do While Timer  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
Function ReplaceGermans(ByVal strText As String) As String
'Funktion ersetzt deutsche Umlaute
'Variablendeklaration
'Integer
Dim iCnt%
'Array
Dim arrRep
'Array mit Umlauten und Replacements definieren
arrRep = Array("?", "Oe", "?", "oe", "?", "Ae", "?", "ae", "?", "Ue", "?", "ue", "?", "ss")
'Schleife von 0 bis Ende vom Array, Schrittweite 2
For iCnt = 0 To UBound(arrRep) Step 2
'Umlaut mit Replacement ersetzen
strText = Replace(strText, arrRep(iCnt), arrRep(iCnt + 1))
'Ende Schleife von 0 bis Ende vom Array, Schrittweite 2
Next
'ReplaceGermans = strText
ReplaceGermans = strText
End Function

Anzeige
Dein API-Key publizieren, wird kosten! (owT)
31.10.2018 09:24:01
EtoPHG

Guter Hinweis, Eto! TE: Frag Herber, ...
31.10.2018 09:46:52
lupo1
... ob er Deinen Code bearbeitet.
Oder frag Google, ob sie Deinen Key sperren und Dir einen neuen geben.
AW: Guter Hinweis, Eto! TE: Frag Herber, ...
31.10.2018 19:09:22
Oisse
Tja, danke ist mir nach dem Senden auch aufgefallen. Aber ich hab den Schlüssel gelöscht, und wenn ich ihn bei mir ausprobiere kommen keine Daten mehr.
Aber wie fragt man bei Herber nach, ob er den Code bearbeitet. Schade, dass man seine eigenen Beiträge nicht mehr bearbeiten kann.
Per E-Mail - aber in diesem Falle bitte nicht mehr
01.11.2018 06:43:43
lupo1
... und auch sonst nur in extremen Fällen, etwa Beleidigung oder Gefahr für Leib und Leben.
Hans W. Herber ist der einzige Betreuer, im Ruhestand und nicht die Mama für Fehler beim Posten.
Früher konnte man auch in den newsgroups (sind aus der Mode) und bei online-excel (gibt es seit Mai 2018 nicht mehr) Beiträge nicht mehr korrigieren! Für die älteren von uns ist das also durchaus vertraut.
Anzeige
Entfernungsermittlung
01.11.2018 07:49:52
Pit30
Moin
Danke für den Code / Formel. Trotzdem bekomme ich es nicht gebacken weil ich die Zuweisung für das Modul
• Hier steht - Start
• Hier steht - Ziel
• Ausgabe - Entfernung in km
• Etc.
nicht umsetzen kann.
Ich habe mein altes Excel-Kalkulations-Tool auf ein min. zurechtgestutzt, den alten (Google hat es ja gestoppt) Code / Formel zum Verständnis drin gelassen.
Den neuen Code / Formel ins Modul 1 kopiert. Aber ich komme einfach nicht weiter.
Meinen persönliche API Code ist durch ,,,XXX_999_YYY,, ersetzt.
Wie muss der Code aussehen, dass sich das System
Start aus Spalte A und Ziel aus Spalte B nimmt und das Ergebnis in Spalte C liefert?
https://www.herber.de/bbs/user/125036.xlsm
Grüße
am Feiertag
Peter
Anzeige
AW: Entfernungsermittlung
02.11.2018 16:20:58
Oisse
Hallo Peter,
ich dachte man hätte dir mittlerweile weitergeholfen. Teste mal die Mappe, die ich dir zurückschicke (natürlich mit deiner API). Ich habe deiner Tabelle noch zwei Spalten für jeweils die Postleitzahl hinzugefügt. Ich war mir nicht sicher, ob du immer den gleichen Zielort hast, oder ob du auch Zeile für Zeile einen anderen Zielort hast. Wenn du jeweils einen anderen hast, musst du in den Code gehen, und dort das Apostroph bei der einen Zeile wegnehmen und bei der anderen setzen (ich habe sie beschriftet, um was es dabei geht).
Gruß Oisse
https://www.herber.de/bbs/user/125077.xlsm
Anzeige
AW: Entfernungsermittlung
03.11.2018 10:20:15
Pit30
Hallo Oisse
Perfekt, vielen, vielen Dank.
VG
Peter
AW: Entfernungsermittlung
04.11.2018 16:43:26
Oisse
Sehr gerne,
ich freue mich, dass ich Dir helfen konnte und über das Feedback.
Gruß
Oisse

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige