Makro als Schleife anpassen (Distanz zwischen Adressen)

[carrion-crow]

Hallo liebe Excel und VBA Experten,
ich habe ein Macro gefunden welche die Entfernung und die Zeit zwischen zwei Adressen berechnet.
Die Startadresse ist A1 und die Ziel Adresse ist B1.
Die Distanz wird in C1 ausgegeben und die Zeit in D1.

Nun Zum Problem: Ich habe eine Liste mit über 3000 Zeilen. Dieses Makro soll bis zu letzten Zeile laufen.
Sollte eine Zeile Falsch sein oder nicht zu berechnen sein soll das Makro nicht abbrechen sondern in C und D jefeils "falsch" eintragen.

Ich hoffe ich konnte mich verständlich genug Ausdrücken.

Code:

Public Sub GoogleTest()
'Variablendeklarastionen
'Objekt - Late Binding
Dim objXML As Object 'fuer XML-"String"
Dim xmlDoc As Object
Dim xmlNod As Object
'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")
'Wenn Instanzierung nicht nichts gebracht hat, dann
If Not objXML Is Nothing Then
  'OriginAddress ermitteln
  'Hinweise:
  'PLZ auch 4stellig moeglich
  strOAddr = "Deutschland, " & Format(Cells(1, 1), "0####")
  'DestinationAddress ermitteln
  'Hinweise:
  'PLZ nicht 4stellig moeglich!
  strDAddr = "Deutschland, " & Format(Cells(1, 2), "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"
      Set xmlNod = xmlDoc.SelectSingleNode("//row/element/duration/value")
      'Zeit in Stundenzelle eintragen, Rueckgabewert / 86400
      Cells(1, 4) = 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(1, 3) = xmlNod.Text / 1000
  'Zeit in Stundenzelle eintragen, Rueckgabewert / 86400
  Cells(1, 4) = CDate(xmlNod.Text / 86400)
'Ende Wenn Instanzierung nicht nichts gebracht hat, dann
End If
'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

Besten Dank schon mal für eure Hilfe.

Grüße
Thilo

[schauan]

Hallöchen,

kennst Du dich etwas mit VBA aus,

erst mal das Ding mit den 3000 Zeilen. Das kann man mit verschiedenen Arten von Schleifen lösen.

Schreibe oben im Dim-Bereich noch
Dim iCnt%

über
'Wenn Instanzierung nicht nichts gebracht hat, dann

schreibst Du
For iCnt = 1 to 3000

und unter
'Ende Wenn Instanzierung nicht nichts gebracht hat, dann
End If

schreibst Du
Next

Dann ersetzt Du
Cells(1 ...

durch

Cells(iCnt ...


Klappt das? Dann machen wir mit den "Leereinträgen" weiter.

[carrion-crow]

Hallo Schauan,
Es Funktioniert sehr gut.
Leider bricht die Funktion ab wenn ein Fehler kommt.
[
Bild bitte so als Datei hochladen: Klick mich!
]
Ist es möglich, dass das Makro in diesem Fall einfach zur nächsten Adresse springt?
Leere Zellen gibts es zum Glück doch keine. Das heißt mit " For iCnt = 1 To 3000" komme ich ans Ziel.


Ich bin leider kein VBA Profi.

Beste Grüße

[DbSam]

Grüße return,

Ich bin leider kein VBA Profi.

Dann schau doch bitte mal hier, vielleicht könnte das Deinen Anforderungen schon genügen.


Gruß Carsten

[carrion-crow]

Hallo Carsten,
das ist mir bekannt und es ist keine Option.
Schauan hat mir schon sehr gut geholfen. Wenn ich jetzt noch erfahre wie Fehler übersprungen werden bin ich glücklich!

[DbSam]

Hallo  Glücklicher,

Fehler werden mit 'On Error Resume Next' ignoriert.
Dies gilt innerhalb der Sub/Function bis zur nächsten 'On Error'-Anweisung, also das Einschalten nicht vergessen.

Wenn man aber schon an einigen Stellen Fehler schon erwartet, dann sollten diese in eine separate Routine ausgelagert werden.


Gruß Carsten

PS:
Keine Option? - Macht genau das, was Du in Deiner ersten Frage als Anforderung definiert hast.

[carrion-crow]

Hallo Carsten,
es sind da noch ein paar mehr sachen drinn.
Danke für deinen Tipp. da überspringt er die Fehler. Leider stürzt Excel nach 25 Datensätzen ab.
Anonsten tut es jetzt schon das was es soll.

[DbSam]

Hallo return,

naja, wenn die Excelabstürze geplant sind, dann funktioniert der Code sicherlich gut.  ;)
Wenn Dein Code kein Geheimnis, dann könntest Du diesen hier posten und man könnte mal drüberschauen.


Gruß Carsten
:D

[carrion-crow]

Das ist der Code.
er läuft bis zur Adresse 450. danach ist Ende. Auch wenn ich die restlichen Adressen neu in ein Blatt kopiere macht er nichts mehr.
Ist es denkbar, dass google nur eine gewisse anzahl an zugriffen zulässt?

Code:

Public Sub Google()
'Variablendeklarastionen
'Objekt - Late Binding
Dim objXML As Object 'fuer XML-"String"
Dim xmlDoc As Object
Dim xmlNod As Object
Dim iCnt%
'Objekt - Early Binding
   'Dim xmlDoc As New MSXML2.DOMDocument
   'Dim xmlNod As MSXML2.IXMLDOMNode
'String
Dim strOAddr$, strDAddr
On Error Resume Next
'XML-Objecte instanzieren
Set objXML = CreateObject("Msxml2.XMLHTTP")
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
For iCnt = 1 To 1376
'Wenn Instanzierung nicht nichts gebracht hat, dann
If Not objXML Is Nothing Then
 'OriginAddress ermitteln
 'Hinweise:
 'PLZ auch 4stellig moeglich
 strOAddr = Format(Cells(iCnt%, 2), "0####")
 'DestinationAddress ermitteln
 'Hinweise:
 'PLZ nicht 4stellig moeglich!
 strDAddr = Format(Cells(iCnt%, 3), "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"
     Set xmlNod = xmlDoc.SelectSingleNode("//row/element/duration/value")
     'Zeit in Stundenzelle eintragen, Rueckgabewert / 86400
     Cells(iCnt%, 5) = 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(iCnt%, 4) = xmlNod.Text / 1000
 'Zeit in Stundenzelle eintragen, Rueckgabewert / 86400
 Cells(iCnt%, 5) = CDate(xmlNod.Text / 86400)
'Ende Wenn Instanzierung nicht nichts gebracht hat, dann
End If
Next
'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

[DbSam]

Hallo Thilo,

wenn Du die Distance Matrix API intensiv nutzen willst, dann kannst Du Dich mal hier ff. umschauen.
Infos über die Kontigente findest Du hier.

Ansonsten, zum Code:
Naja, sagen wir mal so: sehr 'freihändig' ...

Es erfolgt keinerlei Prüfung auf Inhalte und Rückgabewerte, da kann es eigentlich nur irgendwann und irgendwo knallen.
Weiterhin werden immer 1376 Zeilen abgefragt - das wird sicherlich nicht immer erwünscht sein und wird das freie Kontingent pro Tag schnell erreichen, bzw. überschreiten.

Lange Rede, kurzer Sinn:
Wenn ich diesen Code jetzt 'DAU-sicher' anpassen würde, dann würde ich wieder in Richtung meines obigen und von Dir abgelehnten Links abdriften. Und diesen dann vielleicht wieder so zerpflücken, dass Du dieses Konstrukt vielleicht wieder ablehnen würdest.

Hast Du Dir mal das Beispiel ohne VBA-Code angesehen?


Gruß Carsten