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