distancier excel vba

Version imprimable

18/02/2018, 14h50
roch2a

distancier excel vba

Bonjour à tous,

Dans le cadre de mon travail j'ai eu besoin de calculer des distances et des temps d'une adresse à une autre.

Pour information j'entre une adresse de départ en A2 et une adresse de destination en B2 et ma macro calcule la distance et le temps entre les deux adresses en faisant appelle à une api google.
Le résultat est renvoyé dans les cellules C2 à H2

Cela fonctionne correctement et plutôt rapidement.

Novice en VBA j'ai passé beaucoup de temps à chercher et adapter des codes.

Mon problème aujourd'hui est que je ne sais pas comment adapter mon code pour faire en sorte que ma macro fonctionne automatiquement pour toutes les autres lignes renseignées dans les colonnes A et B à partir de la cellule A2 et jusqu'à la dernière ligne non vide.
Pour être plus précis les cellules des colonnes A et B seront remplies automatiquement (plusieurs centaines de lignes) et j'aimerais que ma macro fonctionne pour chaque ligne.

Honnêtement je sèche sur le code et j'ai peu de temps pour finir mon boulot et je ne suis pas sur de pouvoir faire tout cela manuellement adresse par adresse et ensuite copier coller les résultats pour les consolider.

Merci de votre aide à toutes et tous.
Cordialement.

PS je peux vous fournir une capture des codes macro au besoin ainsi que de mon fichier excel.
18/02/2018, 14h55
patricktoulon

re

bonjour
il y a deja exactement cela dans le forum ou contributions
il faut chercher un peu quand meme ;)
18/02/2018, 15h02
nicogef

code vba

bonjour
peut tu poster ton code vba ?
pour voir comment il est fait
cordialement
nicogef

1 pièce(s) jointe(s)

Citation:

Envoyé par nicogef

bonjour
peut tu poster ton code vba ?
pour voir comment il est fait
cordialement
nicogef

Bonjour voici le code de la macro

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Sub distancier_google()
 
'Dans l’exemple l’adresse de départ et d’arrivée sont en Feuil1 cellule A2 et B2
'On va recupérer la distance et le temps de parcours en fonction des lieux saisis
 
 
 
'ActiveWorkbook.Worksheets(1).Cells(2, 1).Value = ""
'ActiveWorkbook.Worksheets(1).Cells(2, 2).Value = ""
ActiveWorkbook.Worksheets(1).Cells(2, 3).Value = ""
ActiveWorkbook.Worksheets(1).Cells(2, 4).Value = ""
ActiveWorkbook.Worksheets(1).Cells(2, 5).Value = ""
ActiveWorkbook.Worksheets(1).Cells(2, 6).Value = ""
ActiveWorkbook.Worksheets(1).Cells(2, 7).Value = ""
ActiveWorkbook.Worksheets(1).Cells(2, 8).Value = ""
 
' Initialisaton des variables
 
'lancement de l'api google la clef est personnelle et doit être modifiée
 
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
 
xmlDoc.Async = "false"
 
URL = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & ActiveWorkbook.Worksheets(1).Cells(2, 1).Value & "&destinations=" & ActiveWorkbook.Worksheets(1).Cells(2, 2).Value & "&language=fr-FR&key=entrer votre code api google"
 
xmlDoc.Load (URL)
 
For Each Distances In xmlDoc.SelectNodes("/DistanceMatrixResponse")
 
  Status = Distances.SelectSingleNode("status").Text
 
  If Status = "OK" Then
 
      Depart = Distances.SelectSingleNode("origin_address").Text
 
      Arrivee = Distances.SelectSingleNode("destination_address").Text
 
      For Each Row In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element")
 
        Status = Row.SelectSingleNode("status").Text
 
        If Status = "OK" Then
 
            'on imbrique 2 boucles "la distance" et le "temps"
            For Each Distance In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element/distance")
 
              En_M = Distance.SelectSingleNode("value").Text
 
              En_KM = Distance.SelectSingleNode("text").Text
 
              For Each Duration In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element/duration")
 
              En_SS = Duration.SelectSingleNode("value").Text
 
              En_MM = Duration.SelectSingleNode("text").Text
 
              Next
 
 
            Next
 
          Else
 
        End If
 
      Next
 
    Else
 
  End If
 
Next
 
Set xmlDoc = Nothing
 
 
'on recuère le résultat des boucles dans les cellules C2 à H2
 
ActiveWorkbook.Worksheets(1).Cells(2, 3).Value = Depart
ActiveWorkbook.Worksheets(1).Cells(2, 4).Value = Arrivee
ActiveWorkbook.Worksheets(1).Cells(2, 5).Value = En_KM
ActiveWorkbook.Worksheets(1).Cells(2, 6).Value = En_M
ActiveWorkbook.Worksheets(1).Cells(2, 7).Value = En_MM
ActiveWorkbook.Worksheets(1).Cells(2, 8).Value = En_SS
 
 
Range("A2").Select
 
 
End Sub

Et sur la feuille1

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim KeyCells As Range
 
  Set KeyCells = Range("A2:B2")
  If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
 
    If (ActiveWorkbook.Worksheets(1).Cells(2, 1).Value <> "") And (ActiveWorkbook.Worksheets(1).Cells(2, 2).Value <> "") Then
    distancier_google
    End If
 
 
  End If
 
 
End Sub

et le résultat

Pièce jointe 352211

18/02/2018, 15h58
roch2a

Citation:

Envoyé par patricktoulon

bonjour
il y a deja exactement cela dans le forum ou contributions
il faut chercher un peu quand meme ;)

Merci de la réponse mais un lien aurait été une aide précieuse ....

Nous ne sommes pas tous des experts sinon nous ne serions pas ici et si parfois nos demandes, à nous humbles débutants, peuvent semblez idiotes, les réponses inutiles pour ne pas dire vexantes ne le sont pas moins...

code vba

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
Sub distancier_google()
 
'Dans l’exemple l’adresse de départ et d’arrivée sont en Feuil1 cellule A2 et B2
'On va recupérer la distance et le temps de parcours en fonction des lieux saisis
With Worksheets(1)
Dim nbligne As Long
nbligne = GetLastLineInRange(.Range("a1:b1"))
End With
 
For i = 2 To nbligne Step 1
 
'ActiveWorkbook.Worksheets(1).Cells(i, 1).Value = ""
'ActiveWorkbook.Worksheets(1).Cells(i, 2).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 3).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 4).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 5).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 6).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 7).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 8).Value = ""
 
' Initialisaton des variables
 
'lancement de l'api google la clef est personnelle et doit être modifiée
 
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
 
xmlDoc.Async = "false"
 
URL = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & ActiveWorkbook.Worksheets(1).Cells(i, 1).Value & "&destinations=" & ActiveWorkbook.Worksheets(1).Cells(i, 2).Value & "&language=fr-FR&key=lancement de l'api google la clef est personnelle et doit être modifiée"
 
xmlDoc.Load (URL)
'MsgBox (URL)
 
For Each Distances In xmlDoc.SelectNodes("/DistanceMatrixResponse")
 
Status = Distances.SelectSingleNode("status").Text
 
If Status = "OK" Then
 
Depart = Distances.SelectSingleNode("origin_address").Text
 
Arrivee = Distances.SelectSingleNode("destination_address").Text
 
For Each Row In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element")
 
Status = Row.SelectSingleNode("status").Text
 
If Status = "OK" Then
 
'on imbrique 2 boucles "la distance" et le "temps"
For Each Distance In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element/distance")
 
En_M = Distance.SelectSingleNode("value").Text
 
En_KM = Distance.SelectSingleNode("text").Text
 
For Each Duration In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element/duration")
 
En_SS = Duration.SelectSingleNode("value").Text
 
En_MM = Duration.SelectSingleNode("text").Text
 
Next
 
 
Next
 
Else
 
End If
 
Next
 
Else
 
End If
 
Next
 
Set xmlDoc = Nothing
 
 
'on recuère le résultat des boucles dans les cellules C2 à H2
 
ActiveWorkbook.Worksheets(1).Cells(i, 3).Value = Depart
ActiveWorkbook.Worksheets(1).Cells(i, 4).Value = Arrivee
ActiveWorkbook.Worksheets(1).Cells(i, 5).Value = En_KM
ActiveWorkbook.Worksheets(1).Cells(i, 6).Value = En_M
ActiveWorkbook.Worksheets(1).Cells(i, 7).Value = En_MM
ActiveWorkbook.Worksheets(1).Cells(i, 8).Value = En_SS
 
Next i
 
 
End Sub

ajout de la fonction dernière ligne non vide

Code:

1
2
3
4
5
6
7
8
9
10
' Retourne la dernière ligne d'une plage de cellule
Public Function GetLastLineInRange(plage As Range) As Long
    Dim col As Long
    GetLastLineInRange = plage.Row
    For col = plage.Column To (plage.Column + plage.Columns.Count - 1)
        Dim foundLine As Long
        foundLine = plage.Worksheet.Cells(Rows.Count, col).End(xlUp).Row
        If foundLine > GetLastLineInRange Then GetLastLineInRange = foundLine
    Next col
End Function

et suppression

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Et sur la feuille1
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim KeyCells As Range
 
Set KeyCells = Range("A2:B2")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
 
If (ActiveWorkbook.Worksheets(1).Cells(2, 1).Value <> "") And (ActiveWorkbook.Worksheets(1).Cells(2, 2).Value <> "") Then
distancier_google
End If
 
 
End If
 
 
End Sub

18/02/2018, 16h53
patricktoulon

re

re
le fait de faire une recherche dans le forum et sous forum n'a rien a voir avec le fait d'etre expert ou non
juste un peu de bon sens

et surtout inversement a ce que tu crois c'est toi qui fait preuve de non respect des contributeurs (si je puis m'exprimer ainsi ) qui se sont donnés la peine de rédiger des contributions afin que toi parmis tant d'autres puissent jouir sans efforts du fruit de leur travail

tu galere tu es dans le codage je te comprends je ne t'en tiendrais pas riqueur ;)

et comme je suis d'une humeur généreuse je vais te donner un conseil en ce qui concerne les requettes google maps qui sont deja limitées en terme de nombre par jour pour les non licenciés
reflechis a l'evenement calculate du sheet qui a chaque changement va tout recalculer et donc refaire n(nombre de cellule avec ta formule de ta plage) et donc le nombre limité de requete va se reduire a trois pommes et un cannard

autrement dis d'une part je te conseille que des qu'une cellule a changée la figer en lui mettant sa propre valeur a fin de faire peter la formule d'apel a ta dite fonction

je parierais a 10/1 que tu n'y avais pas pensé et donc que toute la base de ton projet sans que tu en connaisse la moindre methode est deja bancale

je te laisse faire des recherches sur general vba ou excel vba
prouve moi que tu a pris la peine de chercher et je te donnerais la base pour ta solution
amicalement ;)

Citation:

Envoyé par nicogef

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
Sub distancier_google()
 
'Dans l’exemple l’adresse de départ et d’arrivée sont en Feuil1 cellule A2 et B2
'On va recupérer la distance et le temps de parcours en fonction des lieux saisis
With Worksheets(1)
Dim nbligne As Long
nbligne = GetLastLineInRange(.Range("a1:b1"))
End With
 
For i = 2 To nbligne Step 1
 
'ActiveWorkbook.Worksheets(1).Cells(i, 1).Value = ""
'ActiveWorkbook.Worksheets(1).Cells(i, 2).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 3).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 4).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 5).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 6).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 7).Value = ""
ActiveWorkbook.Worksheets(1).Cells(i, 8).Value = ""
 
' Initialisaton des variables
 
'lancement de l'api google la clef est personnelle et doit être modifiée
 
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
 
xmlDoc.Async = "false"
 
URL = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & ActiveWorkbook.Worksheets(1).Cells(i, 1).Value & "&destinations=" & ActiveWorkbook.Worksheets(1).Cells(i, 2).Value & "&language=fr-FR&key=lancement de l'api google la clef est personnelle et doit être modifiée"
 
xmlDoc.Load (URL)
'MsgBox (URL)
 
For Each Distances In xmlDoc.SelectNodes("/DistanceMatrixResponse")
 
Status = Distances.SelectSingleNode("status").Text
 
If Status = "OK" Then
 
Depart = Distances.SelectSingleNode("origin_address").Text
 
Arrivee = Distances.SelectSingleNode("destination_address").Text
 
For Each Row In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element")
 
Status = Row.SelectSingleNode("status").Text
 
If Status = "OK" Then
 
'on imbrique 2 boucles "la distance" et le "temps"
For Each Distance In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element/distance")
 
En_M = Distance.SelectSingleNode("value").Text
 
En_KM = Distance.SelectSingleNode("text").Text
 
For Each Duration In xmlDoc.SelectNodes("/DistanceMatrixResponse/row/element/duration")
 
En_SS = Duration.SelectSingleNode("value").Text
 
En_MM = Duration.SelectSingleNode("text").Text
 
Next
 
 
Next
 
Else
 
End If
 
Next
 
Else
 
End If
 
Next
 
Set xmlDoc = Nothing
 
 
'on recuère le résultat des boucles dans les cellules C2 à H2
 
ActiveWorkbook.Worksheets(1).Cells(i, 3).Value = Depart
ActiveWorkbook.Worksheets(1).Cells(i, 4).Value = Arrivee
ActiveWorkbook.Worksheets(1).Cells(i, 5).Value = En_KM
ActiveWorkbook.Worksheets(1).Cells(i, 6).Value = En_M
ActiveWorkbook.Worksheets(1).Cells(i, 7).Value = En_MM
ActiveWorkbook.Worksheets(1).Cells(i, 8).Value = En_SS
 
Next i
 
 
End Sub

ajout de la fonction dernière ligne non vide

Code:

1
2
3
4
5
6
7
8
9
10
' Retourne la dernière ligne d'une plage de cellule
Public Function GetLastLineInRange(plage As Range) As Long
    Dim col As Long
    GetLastLineInRange = plage.Row
    For col = plage.Column To (plage.Column + plage.Columns.Count - 1)
        Dim foundLine As Long
        foundLine = plage.Worksheet.Cells(Rows.Count, col).End(xlUp).Row
        If foundLine > GetLastLineInRange Then GetLastLineInRange = foundLine
    Next col
End Function

et suppression

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Et sur la feuille1
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim KeyCells As Range
 
Set KeyCells = Range("A2:B2")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
 
If (ActiveWorkbook.Worksheets(1).Cells(2, 1).Value <> "") And (ActiveWorkbook.Worksheets(1).Cells(2, 2).Value <> "") Then
distancier_google
End If
 
 
End If
 
 
End Sub

Merci beaucoup pour ton aide tes modifications sont parfaites

18/02/2018, 17h50
roch2a

Citation:

Envoyé par patricktoulon

re
le fait de faire une recherche dans le forum et sous forum n'a rien a voir avec le fait d'etre expert ou non
juste un peu de bon sens

et surtout inversement a ce que tu crois c'est toi qui fait preuve de non respect des contributeurs (si je puis m'exprimer ainsi ) qui se sont donnés la peine de rédiger des contributions afin que toi parmis tant d'autres puissent jouir sans efforts du fruit de leur travail

tu galere tu es dans le codage je te comprends je ne t'en tiendrais pas riqueur ;)

et comme je suis d'une humeur généreuse je vais te donner un conseil en ce qui concerne les requettes google maps qui sont deja limitées en terme de nombre par jour pour les non licenciés
reflechis a l'evenement calculate du sheet qui a chaque changement va tout recalculer et donc refaire n(nombre de cellule avec ta formule de ta plage) et donc le nombre limité de requete va se reduire a trois pommes et un cannard

autrement dis d'une part je te conseille que des qu'une cellule a changée la figer en lui mettant sa propre valeur a fin de faire peter la formule d'apel a ta dite fonction

je parierais a 10/1 que tu n'y avais pas pensé et donc que toute la base de ton projet sans que tu en connaisse la moindre methode est deja bancale

je te laisse faire des recherches sur general vba ou excel vba
prouve moi que tu a pris la peine de chercher et je te donnerais la base pour ta solution
amicalement ;)

"les requettes google maps qui sont deja limitées en terme de nombre par jour pour les non licenciés" : ce qui n'est pas mon cas mais cela est vrai.
" je te conseille que dès qu'une cellule a changé de la figer en lui mettant sa propre valeur à fin de faire péter la formule d'appel a ta dite fonction": effectivement cela est une bonne idée et pour cette information utile je te remercie.