[XL-2010] Affichage de chemin optimisé entre plusieurs villes

[mercatog]

Salut
Suite à cette discussion http://www.developpez.net/forums/d11...utiers-etapes/
et en adaptant l'approche dans ce sujet pour Excel http://www.developpez.net/forums/d85...-temps-trajet/
Je propose un fichier qui permet d'afficher sur une carte le chemin optimum qui permet de parcourir un ensemble de villes (en circuit ouvert ou en circuit fermé (ville de départ = ville d'arrivée).

La recherche du chemin optimum recours à l'algorithme 2-opt amélioré et de ce fait, l'optimum trouvé peut ne pas être l'optimum absolu, d'où la possibilité de relancer plusieurs fois le code afin d'améliorer les résultats obtenu.

La phase initiale commence par un chemin aléatoire entre les villes.

Description du fichier:
Le fichier est composé de 2 feuilles:
DATA qui comporte:

• La matrice des distances inter villes nommée dynamiquement VILLES. L'intersection de la ligne i et de la colonne j donne la distance entre la ville i et la ville j.
• Le tableau des données GPS de chaque ville (Latitude et Longitude) nommé dynamiquement GPS.

Traitement qui comporte:

• Un contrôle WebBrowser nommé WB qui permet d'afficher sur la carte les villes et le trajet trouvé.
• Une CheckBox nommée ChkFERME qui permet de distinguer si le parcours est en circuit fermé ou ouvert
• 2 boutons qui permettent d'effacer les données et de lancer le code
• La plage I2:I26 nommée INPUT permet de choisir à partir de listes de validation dynamiques les villes avec en I2 la ville de départ
• La plage J2:J26 nommée OUTPUT récupère d'une façon ordonnée le parcours optimal trouvé
• La cellule K2, nommée KM est réservée à la longueur du trajet optimal trouvé. (au cas ou l'optimum est améliorés, l'historique est décalé en bas de la cellule K2

Description du code:
Module OPTIMISATION:

A partir d'un tableau rempli aléatoirement par les villes INPUT , le but du code est de permettre des permutations entre villes i et j, d'insertion d'une ville i entre les villes j et j+1 ou d'une ville j entre les villes i et i+1 ou d'inverser l'ordre du trajet entre les villes i et j (a, b, c) deviendra (c, b, a).
Ces changement ne seront permis que si la différence entre la distance engendrée avec la distance initiale est négative (c'est à dire optimisation).

Le code ci-après est facilement compréhensible avec une schématisation manuelle.

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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
Option Explicit
 
Public Tb() As String                            'Tb tableau à ordonner par échange de villes dans la pile
Public Res() As String                           'Tb tableau optimal ordonné par échange de villes dans la pile
Dim Matrice                                      'Matrice des distances
Public Nb As Byte                                'Nombre de villes +1(Ville de départ=Ville d'arrivée)
Dim Deja As Boolean                              'Pour permettre d'initialiser les tableaux une seule fois
Public Ferme As Boolean                          'Circuit fermé ou ouvert
 
'Diastance entre les villes i et j
Private Function Distance(ByVal i As Byte, j As Byte) As Double
Dim a As Byte, b As Byte
 
If i <> j Then
    For a = 1 To UBound(Matrice, 1)
        If Matrice(1, a) = Tb(i) Then Exit For
    Next a
    For b = 1 To UBound(Matrice, 1)
        If Matrice(b, 1) = Tb(j) Then Exit For
    Next b
    Distance = Matrice(b, a)
End If
End Function
 
'Permute les villes i et j
Private Sub PERMUTE(ByVal i As Byte, j As Byte)
Dim Tmp As String
 
If i <> j Then
    Tmp = Tb(i)
    Tb(i) = Tb(j)
    Tb(j) = Tmp
End If
End Sub
 
'Renverse le parcours entre les villes i et j
Private Sub RENVERSE(ByVal i As Byte, ByVal j As Byte)
Dim a As Byte, b As Byte
 
a = Application.Min(i, j)
b = Application.Max(i, j)
Do While a < b
    PERMUTE a, b
    a = a + 1
    b = b - 1
Loop
End Sub
 
'Insère la ville i entre les villes j et j+1
Private Sub INSERER(ByVal i As Byte, ByVal j As Byte)
Dim Tmp As String
 
If i < j Then
    Tmp = Tb(i)
    Do While i < j
        Tb(i) = Tb(i + 1)
        i = i + 1
    Loop
    Tb(j) = Tmp
End If
End Sub
 
'Insère la ville j entre les villes i et i+1
Private Sub INSERER_INV(ByVal i As Byte, ByVal j As Byte)
Dim Tmp As String
 
If i < j - 1 Then
    Tmp = Tb(j)
    Do While j > i
        Tb(j) = Tb(j - 1)
        j = j - 1
    Loop
    Tb(i) = Tmp
End If
End Sub
 
'Différence de la distance du parcours si on renversait les villes i et j
Private Function DIFF_2OPT(ByVal i As Byte, j As Byte) As Double
Dim d As Double
 
If i < j Then
    d = Distance(i - 1, j) - Distance(i - 1, i)
    If j < Nb Then d = d + Distance(i, j + 1) - Distance(j, j + 1)
    DIFF_2OPT = d
End If
End Function
 
'Différence de la distance du parcours si on insère la ville i entre j et j+1
Private Function DIFF_INSERER(ByVal i As Byte, j As Byte)
Dim d As Double
 
If i < j Then
    d = Distance(i, j) + Distance(i - 1, i + 1) - Distance(i - 1, i) - Distance(i, i + 1)
    If j < Nb Then d = d + Distance(i, j + 1) - Distance(j, j + 1)
    DIFF_INSERER = d
End If
End Function
 
'Différence de la distance du parcours si on insère la ville j entre i et i+1
Private Function DIFF_INSERER_INV(ByVal i As Byte, j As Byte)
Dim d As Double
 
If i < j - 1 Then
    d = Distance(i, j) + Distance(i - 1, j) - Distance(i - 1, i) - Distance(j - 1, j)
    If j < Nb Then d = d + Distance(j - 1, j + 1) - Distance(j, j + 1)
    DIFF_INSERER_INV = d
End If
End Function
 
'Bouclage pour insertion et inversion jusqu'à optimum
Private Sub CALCUL_PARCOURS_2OPT_INSERER()
Dim i As Byte, j As Byte, s As Byte
Dim Modif As Boolean
 
s = -1 * Ferme
Do
    Modif = False
    For i = 2 To Nb - s - 1
        For j = i + 1 To Nb - s
            If DIFF_2OPT(i, j) < 0 Then
                RENVERSE i, j
                Modif = True
            End If
        Next j
    Next i
    'au cas où le nombre de villes est petit, pas la peine cette partie du code
    If Nb > 6 Then
        For i = 2 To Nb - s - 2
            For j = i + 2 To Nb - s
                If DIFF_INSERER(i, j) < 0 Then
                    INSERER i, j
                    Modif = True
                ElseIf DIFF_INSERER_INV(i, j) < 0 Then
                    INSERER_INV i, j
                    Modif = True
                End If
            Next j
        Next i
    End If
Loop While Not Modif
End Sub
 
'Initialise un parcours au hasard
Private Sub HASARD()
Dim i As Byte, j As Byte, a As Byte, b As Byte, s As Byte
Dim Brut As Variant
 
s = -1 * Ferme
If Not Deja Then
    With Worksheets("TRAITEMENT")
        Brut = .Range("I2", .Range("I29").End(xlUp))
    End With
    Matrice = Worksheets("DATA").Range("VILLES").Value
    Nb = UBound(Brut, 1) + s
    ReDim Tb(1 To Nb)
    ReDim Res(1 To Nb, 1 To 2)
    For i = 1 To Nb
        j = IIf((i = Nb) And Ferme, 1, i)
        Tb(i) = Brut(j, 1)
    Next i
End If
 
'ici on permute aléatoirement les éléments du tableau Tb
For i = 2 To Nb - s
    Randomize i
    a = Int((Nb - s - 1) * Rnd() + 2)
    Randomize Nb - i
    b = Int((Nb - s - 1) * Rnd() + 2)
    If a <> b Then PERMUTE a, b
Next i
End Sub
 
'Lancement
Public Sub LANCEMENT()
Dim i As Byte, k As Byte
Dim s As Double, So As Double
Dim Trouve As Boolean
Const NbEssais As Byte = 10                      'nombre de boucles pour améliorer l'optimum local
 
Application.ScreenUpdating = False
For k = 1 To NbEssais
    s = 0
    HASARD
    If Nb > 3 Then
        CALCUL_PARCOURS_2OPT_INSERER
        For i = 2 To Nb
            s = s + Distance(i - 1, i)
        Next i
        With Worksheets("TRAITEMENT")
            So = Val(.Range("KM"))
            If s < So Or So = 0 Then
                Trouve = True
                .Range("OUTPUT").ClearContents
                For i = 1 To Nb
                    Res(i, 1) = Tb(i)
                    .Range("OUTPUT").Cells(i, 1) = Tb(i)
                Next i
                .Range("KM").Offset(1, 0).INSERT Shift:=xlShiftDown
                .Range("KM").Offset(1, 0).Value = .Range("KM").Value
                .Range("KM").Offset(1, 0).Interior.ColorIndex = xlNone
                .Range("KM").Value = s
            End If
        End With
    Else
        MsgBox "Nombre de villes insuffisant (minium 4 villes)"
        Exit Sub
    End If
    Deja = True
    If Nb < 6 Then Exit For
Next k
Deja = False
If Trouve Then AFFICHAGE 'Affichage sur la carte
Erase Matrice
Erase Tb
End Sub

Module CARTE:

Ce module permet entre autre de récupérer le tableau final du trajet optimisé et à l'aide des données GPS des villes de tracer le parcours optimal trouvé sur la carte (WebBrowser)

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
Option Explicit
 
Dim Br As WebBrowser
Dim GPS As Variant
 
Private Sub Paus(Optional ByVal NbSec As Single = 0.5)
Dim Mx As Single
 
Mx = (Timer + Abs(NbSec)) Mod 86400
Do While Timer <= Mx
    DoEvents
Loop
End Sub
 
Private Sub Attente()
 
Do While Br.Busy Or Br.ReadyState <> 4
    DoEvents
Loop
End Sub
 
Private Function Forma(ByVal d As Double) As String
 
Forma = Replace(CStr(Round(d, 5)), ",", ".")
End Function
 
Private Sub EffaceCarte()
 
Br.Document.ParentWindow.ExecScript "clearMap()", "JScript"
End Sub
 
Private Sub TraceParcours(ByVal Str As String)
 
Br.Document.ParentWindow.ExecScript Str, "JScript"
End Sub
 
Private Sub TraceVille(ByVal i As Byte)
Dim StrVille As String
 
StrVille = "displayMark(" & Res(i, 2) & "," & """" & Res(i, 1) & """);"
Br.Document.ParentWindow.ExecScript StrVille, "JScript"
End Sub
 
 
Private Function Coord(ByVal Str As String) As String
Dim X As Double, Y As Double
Dim i As Integer
 
For i = 1 To UBound(GPS, 1)
    If GPS(i, 3) = Str Then
        X = GPS(i, 1)
        Y = GPS(i, 2)
        Exit For
    End If
Next i
Coord = Forma(X) & "," & Forma(Y)
End Function
 
Public Sub AFFICHAGE()
Dim StrRoute As String
Dim i As Byte, s As Byte
 
Application.ScreenUpdating = False
GPS = Worksheets("DATA").Range("GPS")
StrRoute = ""
For i = 1 To Nb
    Res(i, 2) = Coord(Res(i, 1))
Next i
 
Set Br = Worksheets("TRAITEMENT").WB
Br.Navigate ThisWorkbook.Path & "\Carte.html"
Attente
EffaceCarte
Attente
 
s = -1 * Ferme
For i = 1 To Nb - s
    Paus 0.4
    TraceVille i
    StrRoute = StrRoute & ":" & Res(i, 2)
Next i
StrRoute = Mid(StrRoute, 2) & IIf(s = 1, ":" & Res(1, 2), "")
StrRoute = "addRoad(""" & StrRoute & """);"
TraceParcours StrRoute
Set Br = Nothing
Erase GPS
End Sub

Module de la feuille TRAITEMENT:

Permet entre autre d'affecter à la plage INPUT des listes de validation dynamiques (pour ne pas saisir des villes en double ou mal orthographiées)
Il permet aussi de gérer l'effacement des plages en fonction des actions de l'utilisateur.

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
Option Explicit
 
Private Sub btnAfichWeb_Click()
 
Ferme = ChkFERME.Value
LANCEMENT
End Sub
 
Private Sub ChkFERME_Click()
 
Ferme = ChkFERME.Value
Range("KM").EntireColumn.ClearContents
Range("OUTPUT").ClearContents
End Sub
 
Private Sub Reset_Click()
 
Range("INPUT").ClearContents
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
Dim Str As String
 
If Not Intersect(Target, Range("INPUT")) Is Nothing Then
    Str = Lst
    For Each c In Range("INPUT")
        c.Validation.Delete
        If Len(Str) > 0 Then c.Validation.Add xlValidateList, , , Str
    Next c
End If
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
If Not Intersect(Target, Range("INPUT")) Is Nothing Then
    Application.EnableEvents = False
    Range("KM").EntireColumn.ClearContents
    Range("OUTPUT").ClearContents
    Application.EnableEvents = True
End If
End Sub
 
Private Function Lst() As String
Dim Str As String
Dim Plage As Range, c As Range, v As Range
 
For Each c In Worksheets("DATA").Range("GPS").Columns(3).Cells
    Set v = Range("INPUT").Find(c.Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not v Is Nothing Then
        Set v = Nothing
    Else
        Str = Str & "," & c.Value
    End If
Next c
If Len(Str) > 1 Then Lst = Mid(Str, 2)
End Function

Fichier annexe Carte.html et sous dossier Carte_fichiers à mettre dans le même dossier que le fichier Excel (Carte de france)

[Vadorblanc]

Bonjour Mercatog
J'essaie de faire fonctionner ta superbe contribution.
Je n'ai pas Excel 2007 mais 2010.
La carte ne s'affiche pas.
C'est compliqué.
Quand j'ouvre le fichier OPTIM TRAJ.xlsm, j'ai un message, Navigation vers la page Web annulée, Essayer la chose suivante...Saisissez à nouveau l'adresse.
Que faut'il que je fasse ?
Merci

[mercatog]

Bonjour Vadorblanc
Le fichier OPTIM TRAJ.xlsm et le fichier Carte.html devront être dans le même dossier.

Sinon, je n'arrive pas à reproduire l'erreur que tu as.

[Vadorblanc]

Bonjour Mercatog
le fichier Carte.html fonctionne bien quand je clic dessus, la carte s'affiche.
Le fichier OPTIM TRAJ.xlsm et le fichier Carte.html sont bien dans le même répertoire comme ta pièce jointe.
Je pense que ce doit être ma configuration d'Excel 2010 par défaut qui bloque l'affichage de la carte, par contre je ne vois pas ce que je dois modifier.
Je mets en pièce jointe la capture du message bloquant.
Je vais essayer de chercher.
Cordialement

[mercatog]

Bonsoir Vadorblanc

C'est dans les options de ton Excel

Fichier> Options> Centre de gestion de la confidentialité> Paramètres du Centre de gestion...>
Ensuite regardes les options de Paramètres ActiveX et Paramètres des macros.
Aussi regarde la Barre des messages.

[Vadorblanc]

Bonsoir
Voilà, ça marche, j'ai du enlever toutes les restrictions dans le menu Options, c'est beau, faire cette prouesse avec Excel, c'est tout simplement génial...
Ton fichier DATA comporte 20 destinations, est-il limité à ce nombre ? car le but est maintenant d'avoir un choix plus grand de villes, mais la difficulté est de rentrer les données longitudes latitudes distances, ce qui n'est pas rapide en manuel, peut-être sur une prochaine version... La géo localisation est un marché porteur et ton application va en faire rêver plus d'un...
Un grand merci à toi, Bonne année Bonne santé, et beaucoup de programmations qui nous comble toujours de plaisir de te lire...
Un lecteur assidu.
Bien cordialement

[philppe27]

Bonsoir à tous,

Travaillant sur la même problématique je me suis permis de modifier le fichier de Mercatog :
J'ai agrandi le tableau qui peut l'être encore en prenant certaines précautions
Possibilité de mettre l'adresse précise (N°, rue etc...)
En modifiant la colonne G dans DATA les actions suivantes sont lancées:
mise à jour de la ligne et de la colonne dans le tableau à partir de Google Maps (on a, donc, un aller et un retour pour chaque destination, valable pour les petites distances)
mise à jour de la latitude et de la longitude à partir du site de la cellule L2
Possibilité d'avoir une optimisation du parcours en fonction du temps définis dans Google Maps au lieu du nbre de km (en mettant une lettre dans la cellule K1 de TRAITEMENT)
Rajout du détail de km (ou temps) entre les étapes dans TRAITEMENT

Cordialement