Calcul distance et temps entre deux adresses
Bonjour
Je me relance dans la macro après quelques lecture de livre, cependant je ne trouve pas ce que je recherche c'est pourquoi j'aurais besoin d'un petit coup de main, je m'explique:
Ma femme étant auxiliaire de vie je souhaite lui faire un programme calculant sont temps de trajet ainsi que la distance entre deux clients. Dans l'idée, je souhaiterais lui faire un fichier client ou elle inscrirait le nom du client ainsi que son adresse. Chaque jour elle n'aurait qu'a sélectionner le client d’où elle part et celui chez qui elle va ensuite. Excel calculerait son temps de trajet ainsi que les kilomètres séparant les deux adresses. Toutes ses données sélectionnées au fur et a mesure s'enregistreraient dans une base de données ce qui lui permettrait de comparer à la fin du mois avec sa fiche de paie si il n'y a pas d'écart (chose courante dans se métier, les patrons se font plaisir). Je ne peux pas faire les calculs au préalable car son emploi du temps change constamment et ce serait trop long de calculer toutes les possibilités vu le nombre de clients.
Auriez vous une base sur laquelle je puisse travailler ? Je cherche un peu partout dans le forum mais je ne trouve que des calculs entre ville qui ne marchent pas avec des adresses précises.
bonjour,
Regarde un peu de ce côté
@+
Salut et merci bernard22,
c'est justement aprés avoir essayé les fichiers compris dans ce lien que je me tourne vers vous car ça ne marche pas avec des adresses précises. Peut être est ce ma faute et je ne rentre pas les bonnes adresses, ou peut être dois je modifier un peut la macro, je vais voire en tout cas en parallèles je suis entrain de la tester et d'essayer de la modifier...
Bon voilà se que j'ai trouvé qui pourrait se rapprocher le plus de ce dont j'ai besoin
J'ai laissé dans les cases à remplir deux adresses test. Avant de les rentrer je les ai sélectionnées dans Google maps pour voir comment le programme les écrit pour être sure qu'il les retrouve. Le résultat: itinéraire non trouvé !
Bonjour h2so4
Merci pour ce lien.
J'ai donc copié le code dans excel. Une fenêtre s'ouvre et je rentre mes deux adresses. Lors du calcul ca me dit "erreur de compilation. Type défini par l'utilisateur non défini"
Voila ou ca bloque dans l'ecriture:
Public Sub GoogleGetRoute(ByVal Fromaddr As String, ByVal Toaddr As String, ByRef rdistance As Long, ByRef rtime As Long, Optional ByVal traceon As Boolean = False)
' Eric De Schrevel 2013, merci de laisser cette référence si vous utilisez ce code
' <!-- e --><a href="mailto:eric.de.schrevel@gmail.com">eric.de.schrevel@gmail.com</a><!-- e -->
' rajouter la référence à microsoft xml 3.0, via le menu developer Tools pour que ceci fonctionne
Dim request As MSXML2.XMLHTTPJe ne comprend pas se que veut dire de rajouter la référence à Microsoft xml 3.0 et mes recherches internet m'indiquent comment faire pour les versions antérieure à Excel 2013, je pense donc qu'il y a une incompatibilité de version.
De plus, la macro à l'air sympa mais dans mon cas le problème est que j'aimerais que ça se fasse automatiquement autrement dit que ça aille rechercher dans le tableau référent les adresses en fonction du nom sélectionné et non pas remplir à chaque fois l'adresse.
Pour les connaisseur je met la copie de la macro complète si vous voyez comment la modifier. Pour l'exemple prenons la case A1 (feuille 1) en adresse de départ et la case A2 (feuille 1) en adresse d'arrivé. Mes connaissances étant trop limitées pour modifier ça peut être quelqu'un saurais:
Sub test()
Dim d As Long
Dim t As Long
frain = InputBox("point de départ (gps (lat, long) ou adresse")
fra = Replace(frain, " ", "+")
toain = InputBox("point d'arrivée (gps (lat, long) ou adresse")
toa = Replace(toain, " ", "+")
Call GoogleGetRoute(fra, toa, d, t)
MsgBox "de " & frain & " à " & toain & vbCrLf & "distance : " & Format(d / 1000, "0.0") & " km, durée : " & Format(t / 86400, "hh:mm")
End Sub
Public Sub GoogleGetRoute(ByVal Fromaddr As String, ByVal Toaddr As String, ByRef rdistance As Long, ByRef rtime As Long, Optional ByVal traceon As Boolean = False)
' Eric De Schrevel 2013, merci de laisser cette référence si vous utilisez ce code
' <!-- e --><a href="mailto:eric.de.schrevel@gmail.com">eric.de.schrevel@gmail.com</a><!-- e -->
' rajouter la référence à microsoft xml 3.0, via le menu developer Tools pour que ceci fonctionne
Dim request As MSXML2.XMLHTTP
Dim xmlresponse As MSXML2.DOMDocument
Dim leg As IXMLDOMNode
Dim googleurl As String
Dim ctr As Integer
rdistance = -1: 'pas parvenu à calculer la distance
rtime = 0
googleurl = "http://maps.google.com/maps/api/directions/xml?sensor=false&mode=DRIVING&origin=" & Fromaddr & "&destination=" & Toaddr
Set request = New MSXML2.XMLHTTP
responsestatus = ""
While responsestatus <> "OK"
request.Open "GET", googleurl, False
request.send
If traceon Then MsgBox request.responseText
Set xmlresponse = request.responseXML
responsestatus = xmlresponse.SelectSingleNode("DirectionsResponse/status").Text
If responsestatus = "OK" Then
ctr = 0
Set leg = xmlresponse.SelectSingleNode("DirectionsResponse/route/leg")
If Not (leg Is Nothing) Then
rtime = CLng(leg.SelectSingleNode("duration/value").Text) ' en secondes
rdistance = CLng(leg.SelectSingleNode("distance/value").Text) 'en mètres
End If
Else
'limite à 2500 consultations de route par jour
'cfr developers.google.com/maps/documentation/directions
ctr = ctr + 1
If responsestatus = "OVER_QUERY_LIMIT" Then
Application.Wait Time + TimeSerial(0, 0, 1)
Else
ctr = 3
End If
If ctr = 3 Then MsgBox ("erreur " & responsestatus): responsestatus = "OK"
End If
Wend
Set leg = Nothing
Set xmlresponse = Nothing
Set request = Nothing
End Subre-Bonjour,
voici une modification du code, (plus nécessaire d'avoir la référence) et conversion des caractères spéciaux qui passent mal dans une requête web
Sub aargh()
Dim d As Long
Dim t As Long
fra = replacecaracc(Sheets("Feuil1").Range("B1"))
toa = replacecaracc(Sheets("Feuil1").Range("B2"))
Call GoogleGetRoute(fra, toa, d, t)
Sheets("Feuil1").Range("A5") = Format(d / 1000, "0.0")
Sheets("Feuil1").Range("A6") = Format(t / 86400, "hh:mm")
End Sub
Public Sub GoogleGetRoute(ByVal Fromaddr As String, ByVal Toaddr As String, ByRef rdistance As Long, ByRef rtime As Long, Optional ByVal traceon As Boolean = False)
' Eric De Schrevel 2013, merci de laisser cette référence si vous utilisez ce code
' <!-- e --><a href="mailto:eric.de.schrevel@gmail.com">eric.de.schrevel@gmail.com</a><!-- e -->
Dim request
Dim xmlresponse
Dim leg
Dim googleurl As String
Dim ctr As Integer
rdistance = -1: 'pas parvenu à calculer la distance
rtime = 0
googleurl = "http://maps.google.com/maps/api/directions/xml?sensor=false&mode=DRIVING&origin=" & Fromaddr & "&destination=" & Toaddr
Set request = CreateObject("MSXML2.XMLHTTP")
responsestatus = ""
While responsestatus <> "OK"
request.Open "GET", googleurl, False
request.send
If traceon Then MsgBox request.responseText
Set xmlresponse = request.responseXML
responsestatus = xmlresponse.SelectSingleNode("DirectionsResponse/status").Text
If responsestatus = "OK" Then
ctr = 0
Set leg = xmlresponse.SelectSingleNode("DirectionsResponse/route/leg")
If Not (leg Is Nothing) Then
rtime = CLng(leg.SelectSingleNode("duration/value").Text) ' en secondes
rdistance = CLng(leg.SelectSingleNode("distance/value").Text) 'en mètres
End If
Else
'limite à 2500 consultations de route par jour
'cfr developers.google.com/maps/documentation/directions
ctr = ctr + 1
If responsestatus = "OVER_QUERY_LIMIT" Then
Application.Wait Time + TimeSerial(0, 0, 1)
Else
ctr = 3
End If
If ctr = 3 Then MsgBox ("erreur " & responsestatus): responsestatus = "OK"
End If
Wend
Set leg = Nothing
Set xmlresponse = Nothing
Set request = Nothing
End Sub
Function replacecaracc(st)
s = st
s1 = "éèêëiïôùàâç"
s2 = "eeeeiiouaac"
For i = 1 To Len(s1)
s = Replace(s, Mid(s1, i, 1), Mid(s2, i, 1))
Next i
replacecaracc = s
End FunctionBon ben avant de cliquer sur le boutton vert je souhaiterais simplement dire merci à h2so4 car .... Ca fonctionne parfaitement.
Me reste plus qu'à faire tout se qui va autour, il se peut donc que je post de nouvelles question mais en attendant pour ce problème c'est résolu
Mille merci
Bonjour,
J'ai aujourd'hui le même genre de problématique que Fiorina (et un niveau plutôt novice concernant les macros...).
Je souhaite donc qu'à partir de l'adresse de départ (Client 1) et celle d'arrivée (Client 2), je puisse obtenir la distance en km et le temps pour cet itinéraire.
Après avoir mis en place la macro, lorsque je la lance une petite fenêtre s'ouvre et m'affiche ce message : "erreur_OVER_QUERY_LIMIT".
Je ne comprend pas ce message ou à quoi il peut être lié ?
Merci de votre aide
Bonjour,
malheureusement Google a changé les règles d'utilisation de ces API, il faut une clé (je pense payante). Voir le site des apis google que j'ai mis en référence dans le code.
Merci pour le retour, je vais aller voir ça... (dommage qu'il faille payer maintenant !)
Bonjour,
voici le code adapté qui devrait vous permettre d'utiliser les apis google si vous avez acquis une clé d'utilisation (n'ayant pas de clé, je n'ai pas pu tester la modification).
Sub aargh()
Dim d As Long
Dim t As Long
Dim k As String
fra = replacecaracc(Sheets("Feuil1").Range("B1"))
toa = replacecaracc(Sheets("Feuil1").Range("B2"))
k = "test" ' votre apikey
Call GoogleGetRoute(fra, toa, d, t, k)
Sheets("Feuil1").Range("A5") = Format(d / 1000, "0.0")
Sheets("Feuil1").Range("A6") = Format(t / 86400, "hh:mm")
End Sub
Public Sub GoogleGetRoute(ByVal Fromaddr As String, ByVal Toaddr As String, ByRef rdistance As Long, ByRef rtime As Long, apikey As String, Optional ByVal traceon As Boolean = False)
' Eric De Schrevel 2013, merci de laisser cette référence si vous utilisez ce code
' <!-- e --><a href="mailto:eric.de.schrevel@gmail.com">eric.de.schrevel@gmail.com</a><!-- e -->
Dim request
Dim xmlresponse
Dim leg
Dim googleurl As String
Dim ctr As Integer
rdistance = -1: 'pas parvenu à calculer la distance
rtime = 0
googleurl = "http://maps.google.com/maps/api/directions/xml?sensor=false&mode=DRIVING&origin=" & Fromaddr & "&destination=" & Toaddr & "&key=" & apikey
MsgBox googleurl
Set request = CreateObject("MSXML2.XMLHTTP")
responsestatus = ""
While responsestatus <> "OK"
request.Open "GET", googleurl, False
request.send
If traceon Then MsgBox request.responseText
Set xmlresponse = request.responseXML
responsestatus = xmlresponse.SelectSingleNode("DirectionsResponse/status").Text
If responsestatus = "OK" Then
ctr = 0
Set leg = xmlresponse.SelectSingleNode("DirectionsResponse/route/leg")
If Not (leg Is Nothing) Then
rtime = CLng(leg.SelectSingleNode("duration/value").Text) ' en secondes
rdistance = CLng(leg.SelectSingleNode("distance/value").Text) 'en mètres
End If
Else
'limite à 2500 consultations de route par jour
'cfr developers.google.com/maps/documentation/directions
ctr = ctr + 1
If responsestatus = "OVER_QUERY_LIMIT" Then
Application.Wait Time + TimeSerial(0, 0, 1)
Else
ctr = 3
End If
If ctr = 3 Then MsgBox ("erreur " & responsestatus): responsestatus = "OK"
End If
Wend
Set leg = Nothing
Set xmlresponse = Nothing
Set request = Nothing
End Sub
Function replacecaracc(st)
s = st
s1 = "éèêëiïôùàâç"
s2 = "eeeeiiouaac"
For i = 1 To Len(s1)
s = Replace(s, Mid(s1, i, 1), Mid(s2, i, 1))
Next i
replacecaracc = s
End FunctionBonjour !
Après exécution du code ci-dessus, une erreur 91 (variable object ou variable de bloc with non définie) apparaît sur cette ligne ci :
responsestatus = xmlresponse.SelectSingleNode("DirectionsResponse/status").Text
Auriez-vous une solution à me proposer ?
Merci d'avance !
Syrcrim
Bonjour,
as-tu une clé qui te donne le droit d'utiliser l'api google ?
Affirmatif, je me suis crée une clé qui me permet de le faire.
Bonjour,
comme indiqué dans un message précédent, n'ayant pas de clé, je ne peux pas tester ni debugger.
Il est possible de s'en créer une gratuite en suivant le guide ci-dessous :
Si cela t'intéresse bien évidement.
Bonjour,
salut h2so4
sans macro
avec ton API-Key dans un fichier séparé ([API_KEY.xlsx]Feuil1'!$A$1) dans le même dossier
Bonjour Steelson,
Merci de ton aide, mais malheureusement il m'affiche toujours #VALEUR! même en suivant à la lettre tes indications ...
Une idée ?
Merci d'avance !
Voici chez moi
Les 2 fichiers cote à cote
Le résultat, y compris avec des adresses incomplètes et comportant des accents
