26.03.2017, 09:08
Hallöchen,
anbei habe ich noch einen Code, um eine kreuzgefährliche
kreuztabellenähnliche Tabelle zu füllen. Voraussetzung ist diesmal, dass sowohl waagerecht als auch senkrecht die Ortsdaten eingetragen werden. Der Code befüllt dann zeilenweise die Tabelle.
Da hier die Eintragungen nicht mehr wie in der Kreuztabelle um die Diagonale "gespiegelt" werden, fällt auf, dass anscheinend gleiche Strecken unterschiedliche Längen aufweisen. Ich habe das heute mit Aschaffenburg und Alzenau geprüft. Google Maps gibt mir zwischen Alzenau nach Aschaffenburg zwei Angebote aus mit 30 km und 27,7 km. In die Tabelle wurden vom Code die 30 km übernommen - etwas genauer als der auf eine Stelle gerundete Wert zur Anzeige in Google Maps.
Für den Rückweg von Aschaffenburg nach Alzenau erhalte ich sogar 3 Vorschläge, 31,4 km, 27,8 km und über Land mit nur 19,8 km. Übernommen wurde hier auch wieder der erste Wert mit 31,4 km.
Hier mal die Tabelle:
anbei habe ich noch einen Code, um eine kreuzgefährliche
kreuztabellenähnliche Tabelle zu füllen. Voraussetzung ist diesmal, dass sowohl waagerecht als auch senkrecht die Ortsdaten eingetragen werden. Der Code befüllt dann zeilenweise die Tabelle.Da hier die Eintragungen nicht mehr wie in der Kreuztabelle um die Diagonale "gespiegelt" werden, fällt auf, dass anscheinend gleiche Strecken unterschiedliche Längen aufweisen. Ich habe das heute mit Aschaffenburg und Alzenau geprüft. Google Maps gibt mir zwischen Alzenau nach Aschaffenburg zwei Angebote aus mit 30 km und 27,7 km. In die Tabelle wurden vom Code die 30 km übernommen - etwas genauer als der auf eine Stelle gerundete Wert zur Anzeige in Google Maps.
Für den Rückweg von Aschaffenburg nach Alzenau erhalte ich sogar 3 Vorschläge, 31,4 km, 27,8 km und über Land mit nur 19,8 km. Übernommen wurde hier auch wieder der erste Wert mit 31,4 km.
Hier mal die Tabelle:
| Arbeitsblatt mit dem Namen 'Tabelle1' | |||||
| A | B | C | D | E | |
| 1 | 63739 | 63755 | 7549 | ||
| 2 | Aschaffenburg | Alzenau | Gera | ||
| 3 | 63739 | Aschaffenburg | x | 31,351 | 341,099 |
| 4 | 63755 | Alzenau | 29,982 | x | 342,167 |
| 5 | 63768 | Hösbach | 10,291 | 35,776 | 338,347 |
| 6 | 99084 | Erfurt | 282,347 | 260,289 | 96,662 |
| 7 | 7743 | Jena | 321,402 | 299,343 | 59,367 |
| Diese Tabelle wurde mit Tab2Html (v2.5.0) erstellt. ©Gerd alias Bamberg |
PHP-Code:
Option Explicit
Public Sub GoogleTest2()
'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
'Integer
Dim iCnt1%, iCnt2%, iCnt3%, iCnt4%
On Error GoTo errorhandler
'Flackern aus
Application.ScreenUpdating = False
'Zeile und Spalte fuer Start Kreuztabelle (erster Schnittpunkt)
'Hinweis: PLZ zwei Spalten links daneben bzw. zwei Zeilen oberhalb
'Hinweis: Ort eine Spalte links daneben bzw. eine Zeile oberhalb
'Hinweis: kleinste Werte daher jeweils 3!
iCnt1 = 3: iCnt2 = 3
'Offsetzaehler: Hilfszaeheler fuer letzte Eintragung einer Zeile
iCnt3 = 0
'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
With Cells(iCnt1, iCnt2)
'Schleife ueber alle OriginAddress anhand Eintraegen in Spalte A + B
'Tue solange Zellinhalt Spalte A nicht leer
Do While .Offset(iCnt3, -2) <> ""
iCnt4 = 1
'OriginAddress ermitteln
'Hinweise:
'PLZ auch 4stellig moeglich
strOAddr = Format(.Offset(iCnt3, -2), "0####") & "," & ReplaceGermans(.Offset(iCnt3, -1))
'Schleife ueber alle DestinationAddress
Do While .Offset(-2, iCnt4 - 1).Value <> ""
'DestinationAddress ermitteln
'Hinweise:
'PLZ nicht 4stellig moeglich!
strDAddr = Format(.Offset(-2, iCnt4 - 1), "0####") & "," & ReplaceGermans(.Offset(-1, iCnt4 - 1))
'Wenn Zieladresse <> Startadresse, dann
If strOAddr <> strDAddr Then
'Abfrage oeffnen
objXML.Open "POST", "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & strOAddr & ",germany&&destinations=" & strDAddr & ",germany&&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
'Entfernung auslesen /Value=Meter /Text = Kilometer mit Angabe "km"
Set xmlNod = xmlDoc.SelectSingleNode("//row/element/distance/value")
'Entfernung in km zelle eintragen, Rueckgabewert / 1000
.Offset(iCnt3, iCnt4 - 1) = xmlNod.Text / 1000
'.Offset(iCnt4 - 1, iCnt3) = xmlNod.Text / 1000
'Alternativ zu Wenn Zieladresse <> Startadresse
Else
.Offset(iCnt3, iCnt4 - 1) = "x"
'Ende Wenn Zieladresse <> Startadresse, dann
End If
iCnt4 = iCnt4 + 1
'Ende Schleife ueber alle DestinationAddress anhand Eintraegen in Spalte A
Loop
'x eintragen
'.Offset(iCnt3, iCnt3) = "x"
'Endzaehler hochsetzen
iCnt3 = iCnt3 + 1
'Ende Tue solange Zellinhalt nicht leer
Loop
End With
'Ende Wenn Instanzierung nicht nichts gebracht hat, dann
End If
'Fehlerbehandlung / Programmende
errorhandler:
'Flackern ein
Application.ScreenUpdating = True
'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
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