Discussion :

[flicky]

Bonjour,
D'abord merci à l'avance a quiconque contribuera à ce que j'en arrive à règler mon problème.

J'ai passé beaucoup de temps à fouiller les forums et par extension, me retrouver à lire et tenter de comprendre un tant soit peu, un paquet de choses sur des problèmes NP-complet, divers algorithmes (Dijkstra, Lin-Kernigan, le cycle hamiltonien, le problème du voyageur de commerce, le problème du postier chinois, etc. ). Au final, je n'ai pas de solution à mon "problème", probablement du fait qu'il est toujours diffèrents en quelques sortes par rapport à la lecture que je fait.
Par exemple, le cas du voyageur de commerce m'apparait un fort bonne piste, mais dans mon cas il y a notamment la différence que je n'ai pas a organiser mon ittinéraire en considérant devoir revenir au point d'origine (ce qui devrait devrait avoir l'avantage d'être moins complexe...).

Voilà un fichier exposant où j'en suis :

Le but :
Créer des regroupements de lieux.

Les"consignes" que je dois respecter :
Je dois arriver a ralier tous les lieux identifiés (désigné par la lattitude (colonne H) et la longitude(colonne I)).
Je dois débuter par le lieux situé le plus au nord-est (désigné par la valeur la plus faible sur l'axe des X (colonne H) et la plus élevé sur l'axe des Y (colonne I)).
Je dois progresser en passant chaque fois par le lieux le plus près (distance à vol d'oiseau).

Je connais la population de chaque lieu (colonne L).
Chaque fois que le cumul de la population des lieux raliers dépasse 15 000 habitants, je dois créer un code (ex. : Regroup1; Regroup2, etc.) qui désigne les lieux inclut dans le regroupement et l'indiquer dans la colonne M.
Je débute ensuite un nouveau regroupement avec le lieux le plus près du dernier lieux inclut dans le regroupement précédent.
Autre petites contrainte : les regroupements ne doivent pas compter plus de 16 000 habitants, donc même si je n'ai pas atteint 15000 habitants dans un regroupement, je ferme ce regroupement plutot que de lui ajouter un lieu qui ferait passé sa population a plus de 16 000 habitants.

[mercatog]

Bonjour
Ci-joint proposition un peu lente (~3.5 min) testée sur ton fichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Const N As Byte = 3
Dim Sh As Worksheet
Dim Tb As Variant
Dim T As Double
 
Sub TRAITEMENT()
Dim LastLig As Long, Nb As Long
 
T = Timer
 
'Création d'une feuille temporaire et y copie les colonnes B, H et I à partir de la feuille BD
Set Sh = ThisWorkbook.Worksheets.Add
With ThisWorkbook.Worksheets("BD")
    LastLig = .Cells(.Rows.Count, 2).End(xlUp).Row
    Union(.Range("B5:B" & LastLig), .Range("H5:I" & LastLig)).Copy Sh.Range("A1")
End With
 
'Nb: nombre de données (nombre de points)
Nb = LastLig - 5
 
With Sh
    'On tri les données an prenant la latitude la plus grande
    .Range("A2:C" & Nb + 1).Sort Key1:=.Range("B2"), Order1:=xlDescending, Header:=xlNo
 
    'On refait un tri des données par ordre croissant des distances à partir du point 1
    'Appel à la procédure TRIER ci-après
    TRIER 2, Nb
 
    'On applique le traitement au tableau (procédures ci-après)
    Tb = .Range("A2:C" & Nb + 1)
    PARCOURS Nb
    .Range("A2:C" & Nb + 1) = Tb
    Erase Tb
 
    'Après traitement, on importe la population de chaque point
    With .Range("D2:D" & Nb + 1)
        .Formula = "=VLOOKUP(A2,BD!$B$6:$L$" & LastLig & ",11,FALSE)"
        .Value = .Value
    End With
    'on fait le regroupement des points selon la population globale
    Tb = .Range("A2:E" & Nb + 1)
    CLASSEMENT Nb
    .Range("A2:E" & Nb + 1) = Tb
End With
 
'on réinjecte le groupement dans la feuille BD
With ThisWorkbook.Worksheets("BD").Range("M6:M" & LastLig)
    .Formula = "=VLOOKUP(B6,'" & Sh.Name & "'!$A$2:$E$" & Nb + 1 & ",5,false)"
    .Value = .Value
End With
'Eventuellement on supprime la feuille temporaire
'Application.DisplayAlerts = False
'Sh.Delete
'Application.DisplayAlerts = True
Set Sh = Nothing
MsgBox "optimisation terminée en " & Format(TimeSerial(0, 0, Timer - T), "hh:mm:ss")
End Sub
 
'procédure qui permet de refaire l'inversion de l'ordre des point tant que la permutation permet de diminuer
'la distance total du parcours (Cf fonction DIFF_2OPT)
 
Private Sub PARCOURS(ByVal Nb As Integer)
Dim p As Integer, q As Integer
Dim Modif As Boolean
Dim Ind As Byte
 
Do
    Modif = False
    Ind = Ind + 1
    For p = 2 To Nb - 1
        For q = p + 1 To Nb
            If DIFF_2OPT(p, q, Nb) < 0 Then
                RENVERSE p, q
                Modif = True
                Application.StatusBar = "Traitement en cours...   Passage " & Ind & " : " & p & " et " & q & "   " & Format(TimeSerial(0, 0, Timer - T), "hh:mm:ss")
            End If
            DoEvents
        Next q
    Next p
Loop Until Not Modif
Application.StatusBar = False
End Sub
 
'Procédure permetant de trier les points d'un échantillon de Nb points
'en prenant comme critère la distance de chaque point par rapport au point k
Private Sub TRIER(ByVal k As Integer, ByVal Nb As Integer)
Dim m As Integer
 
With Sh
    Tb = .Range("A" & k & ":C" & Nb + 1)
    For m = k To Nb + 1
        With .Range("D" & m)
            .Formula = "=Distance(" & k - 1 & "," & m - 1 & ")"
            .Value = .Value
        End With
    Next m
    .Range("A" & k & ":D" & Nb + 1).Sort Key1:=.Range("D" & k), Order1:=xlAscending, Header:=xlNo
    .Range("D" & k & ":D" & Nb + 1).ClearContents
End With
End Sub
 
'procédure qui permet le regroupement des points successifs
'en respactant que la population globale =>15000 et >160000
Private Sub CLASSEMENT(ByVal Nb As Integer)
Dim i As Integer, Indx As Integer
Dim T As Long
 
Indx = 1
For i = 1 To Nb
    T = T + Tb(i, 4)
    Tb(i, 5) = "Groupe_" & Indx
    If T >= 15000 Then
        If T < 16000 Then
            Indx = Indx + 1
            T = 0
        Else
            T = Tb(i, 4)
        End If
    End If
Next i
End Sub
 
 
'Fonction qui permet de claculer la distances entre 2 points i et j
'connaissant les latitudes et longitudes respectives de i et j
Function DISTANCE(ByVal i As Integer, ByVal j As Integer) As Double
Dim Lat1 As Double, Lat2 As Double, Lon1 As Double, Lon2 As Double
Const R As Integer = 6371                          ' de la terre, en km
 
Lat1 = DEG2RAD(Tb(i, 2))
Lon1 = DEG2RAD(Tb(i, 3))
Lat2 = DEG2RAD(Tb(j, 2))
Lon2 = DEG2RAD(Tb(j, 3))
' Calcul
DISTANCE = WorksheetFunction.Acos((Sin(Lat1) * Sin(Lat2)) + (Cos(Lat1) * Cos(Lat2) * Cos(Lon1 - Lon2))) * R
 
End Function
 
' Fonction qui convertit les degrés en radians
Private Function DEG2RAD(ByVal Dg As Double) As Double
Dim pPi As Double
pPi = Application.WorksheetFunction.Pi()
 
DEG2RAD = Dg / 180 * pPi
End Function
 
'Permute les points i et j (dans notre cas on permute respctivement le N°, la latitude et la longitude de i et j)
Private Sub PERMUTE(ByVal i As Integer, ByVal j As Integer)
Dim Tmp(1 To N) As Variant
Dim y As Byte
 
If i <> j Then
    For y = 1 To N
        Tmp(y) = Tb(i, y)
        Tb(i, y) = Tb(j, y)
        Tb(j, y) = Tmp(y)
    Next y
End If
End Sub
 
'Renverse le parcours entre les villes i et j
Private Sub RENVERSE(ByVal i As Integer, ByVal j As Integer)
Dim a As Integer, b As Integer
 
a = Application.Min(i, j)
b = Application.Max(i, j)
Do While a < b
    PERMUTE a, b
    a = a + 1
    b = b - 1
    DoEvents
Loop
End Sub
 
'Différence de la distance du parcours si on renversait les villes i et j
Private Function DIFF_2OPT(ByVal i As Integer, ByVal j As Integer, ByVal Nb As Integer) 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

[flicky]

Franchement Mercatog ta réponse est bien bien au dela de mes attentes, Elle est pour moi (et mon confrère) d'une qualité exceptionnelle.
Je m'attendais à des pistes de solutions, j'aurais jamais cru recevoir une solution "clé en main".
Sincèrement un immense merci à toi.

Bien sur je navais pas exposé ma problématique entière, mais plutot une version sommaire visant a obtenir des pistes de solutions "de logique de résolution". Je suis confiant de pouvoir adapter ta solution par moi-même.

Encore merci !!

[mercatog]

Bonsoir
Néanmoins, une petite modification dans ma procédure de regroupement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
'procédure qui permet le regroupement des points successifs
'en respactant que la population globale =>15000 et >160000
Private Sub CLASSEMENT(ByVal Nb As Integer)
Dim i As Integer, Indx As Integer
Dim T As Long
 
Indx = 1
For i = 1 To Nb
    T = T + Tb(i, 4)
    Tb(i, 5) = "Groupe_" & Indx
    If T >= 15000 Then
        Indx = Indx + 1
        If T < 16000 Then
            T = 0
        Else
            T = Tb(i, 4)
            Tb(i, 5) = "Groupe_" & Indx
        End If
    End If
Next i
End Sub

[aldus_85]

Bonjour !

Voici une proposition, dans un style différent par rapport à Mercatog. Comme l'indique le titre, cette solution n'utilise ni macro ni VBA. Elle utilise cependant l'itération pour faire le job.

Moins de 40 s sur ma bécane pour traiter la base de données fournie.

P.S. le point de départ est le premier point donné. Si cela ne convenait pas, placer en premier le point qui va bien ou mettre "1" d'autorité à la ligne du point choisi.

[ZebreLoup]

Juste une petite remarque au passage. Etant donné les contraintes de ton problème, il n'y avait qu'une seule solution et donc aucune optimisation nécessaire. Tu étais parti sur des choses un peu trop compliquées avec le voyageur de commerce ou autre. Il suffisait d'implémenter l'algorithme que tu décrivais, ce qu'ont fait Mercatog et Aldus de 2 manières différentes.