XL 2016 Affichage villes proches à partir coordonnées GPS

bobland974 · 16 Novembre 2017

Bonjour à tous,

Voilà, cela va bientôt faire deux jours que je tourne le problème dans tous les sens et je n'arrive pas à trouver la solution, je me permets donc de venir vers vous afin de solliciter votre aide.

Je dispose d'un fichier excel avec en
- colonne (A) : nom de la ville
- colonne (F) : coordonnée GPS latitude
- colonne (G) : coordonnée GPS longitude
- colonne H, I, J : nom des 3 villes les plus proches que je désire faire ressortir du tableau
> cf. fichier ville_plus_proche.xls

Je suis parti du fichier de base pour essayer d'en découdre avecu ne formule mais rien n'y fait
(copie de ville_proche.xlsx)

Par quel moyen puis-je réussir à y arriver sans créé autrement autant de colonne (distance) qu'il y a de ligne afin de pouvoir faire ressortir une liste de choix des villes les plus proches. A terme le fichier devrait contenir plusieurs milliers de colonnes.

Y a t il pas une solution plus simple à mettre en oeuvre car vu la quantité de ville dont j'ai à ma disposition cela est compliqué ?

Merci par avance pour votre aide,

job75 · 21 Juillet 2022

Bon voyez ce fichier (2) et le code de l'UserForm :

VB:

Dim tablo 'mémorise la variable

Private Sub ComboBox1_Change() 'Ville
Dim RT$, daMax, i As Variant, Lat, Lon, sinLat, cosLat, j&, da, a(), n&, resu()
RT = 6378.137 'rayon terrestre en km
daMax = Val(ComboBox2) / RT 'distance angulaire max
i = Application.Match(ComboBox1, Columns(1), 0)
If IsNumeric(i) And UBound(tablo) > 2 Then
    Lat = tablo(i, 3): Lon = tablo(i, 4): sinLat = Sin(Lat): cosLat = Cos(Lat)
    For j = 2 To UBound(tablo)
        If j <> i Then
            da = sinLat * Sin(tablo(j, 3)) + cosLat * Cos(tablo(j, 3)) * Cos(Lon - tablo(j, 4)) 'cosinus de la distance angulaire
            da = Atn(Sqr(Abs(1 - da ^ 2)) / da) 'distance angulaire en radian
            If da <= daMax Then
                ReDim Preserve a(1, n) 'base 0
                a(0, n) = tablo(j, 1)
                a(1, n) = RT * da
                n = n + 1
            End If
        End If
    Next j
End If
If n Then
    tri a, 0, n - 1
    ReDim resu(n - 1, 1)
    For j = 0 To n - 1
        resu(j, 0) = a(0, j)
        resu(j, 1) = Format(a(1, j), "0.0 k\m")
    Next j
    ListBox1.List = resu
    ListBox1.ListIndex = -1
Else
    ListBox1.Clear
End If
End Sub

Private Sub ComboBox2_Change() 'Dmax
ComboBox1_Change
End Sub

Private Sub UserForm_Initialize()
With [A1].CurrentRegion.Resize(, 4)
    tablo = .Value
    If .Rows.Count > 1 Then ComboBox1.List = .Offset(1).Resize(.Rows.Count - 1).Value
End With
ComboBox2.List = Array("10 km", "20 km", "30 km", "40 km", "50 km", "100 km", "150 km")
End Sub

Sub tri(a, gauc, droi)  ' Quick sort
Dim ref, g, d, temp
ref = a(1, (gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(1, g) < ref: g = g + 1: Loop
    Do While ref < a(1, d): d = d - 1: Loop
    If g <= d Then
      temp = a(1, g): a(1, g) = a(1, d): a(1, d) = temp
      temp = a(0, g): a(0, g) = a(0, d): a(0, d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

Bonne nuit.

erics83 · 21 Juillet 2022

job75 à dit:

Bon voyez ce fichier (2) et le code de l'UserForm :

VB:

Dim tablo 'mémorise la variable

Private Sub ComboBox1_Change() 'Ville
Dim RT$, daMax, i As Variant, Lat, Lon, sinLat, cosLat, j&, da, a(), n&, resu()
RT = 6378.137 'rayon terrestre en km
daMax = Val(ComboBox2) / RT 'distance angulaire max
i = Application.Match(ComboBox1, Columns(1), 0)
If IsNumeric(i) And UBound(tablo) > 2 Then
    Lat = tablo(i, 3): Lon = tablo(i, 4): sinLat = Sin(Lat): cosLat = Cos(Lat)
    For j = 2 To UBound(tablo)
        If j <> i Then
            da = sinLat * Sin(tablo(j, 3)) + cosLat * Cos(tablo(j, 3)) * Cos(Lon - tablo(j, 4)) 'cosinus de la distance angulaire
            da = Atn(Sqr(Abs(1 - da ^ 2)) / da) 'distance angulaire en radian
            If da <= daMax Then
                ReDim Preserve a(1, n) 'base 0
                a(0, n) = tablo(j, 1)
                a(1, n) = RT * da
                n = n + 1
            End If
        End If
    Next j
End If
If n Then
    tri a, 0, n - 1
    ReDim resu(n - 1, 1)
    For j = 0 To n - 1
        resu(j, 0) = a(0, j)
        resu(j, 1) = Format(a(1, j), "0.0 k\m")
    Next j
    ListBox1.List = resu
    ListBox1.ListIndex = -1
Else
    ListBox1.Clear
End If
End Sub

Private Sub ComboBox2_Change() 'Dmax
ComboBox1_Change
End Sub

Private Sub UserForm_Initialize()
With [A1].CurrentRegion.Resize(, 4)
    tablo = .Value
    If .Rows.Count > 1 Then ComboBox1.List = .Offset(1).Resize(.Rows.Count - 1).Value
End With
ComboBox2.List = Array("10 km", "20 km", "30 km", "40 km", "50 km", "100 km", "150 km")
End Sub

Sub tri(a, gauc, droi)  ' Quick sort
Dim ref, g, d, temp
ref = a(1, (gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(1, g) < ref: g = g + 1: Loop
    Do While ref < a(1, d): d = d - 1: Loop
    If g <= d Then
      temp = a(1, g): a(1, g) = a(1, d): a(1, d) = temp
      temp = a(0, g): a(0, g) = a(0, d): a(0, d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

Bonne nuit.

SUPER !!! Merci Job75, c'est exactement ce que je cherchais à avoir !!!
MERCI !!!

et je vois que je n'aurai pas pu faire le USF (enfin, rapatrier les données....), et d'ailleurs, pour ma compréhension, pourquoi mettre ?

VB:

ListBox1.ListIndex = -1

, je l'ai enlevé pour voir, et le résultat (=l'affichage de resu) est le même....si vous l'avez mis, c'est qu'il y a une bonne raison.

Merci pour vos éclairages,

Merci pour votre aide,
Eric

job75 · 21 Juillet 2022

Bonjour erics83,

erics83 à dit:
pourquoi mettre ?

VB:

ListBox1.ListIndex = -1

, je l'ai enlevé pour voir, et le résultat (=l'affichage de resu) est le même....si vous l'avez mis, c'est qu'il y a une bonne raison.

Oui je viens de l'ajouter.

Cela permet d'enlever le surlignage de la sélection s'il y en a dans la ListBox.

A+

erics83 · 21 Juillet 2022

job75 à dit:
Bonjour erics83,

Oui je viens de l'ajouter.

Cela permet d'enlever le surlignage de la sélection s'il y en a dans la ListBox.

A+

Merci Job75 pour cette explication et encore un grand merci d'avoir pris le temps de me montrer comment réaliser le USF.

Merci pour votre aide,
Eric

Katido · 21 Juillet 2022

Bonsoir,

un degrés d'arc correspond à 111 km ...

Un degré correspond en effet à environ 111 km pour la latitude.
Mais pour la longitude, c'est environ 70 km à Dunkerque et 83 km à Bonifacio.
On pourrait commencer par faire une conversion en d'autres unités, telles que les coordonnées Lambert

Katido · 23 Juillet 2022

Bonjour,

A titre indicatif, le calcul pour 35 000 communes dure chez moi un peu plus d'une minute, avec la vraie formule de trigo sphérique en Arccos(...)
A condition de ne mémoriser que les 3 plus proches et de ne calculer Arccos qu'à la fin des 612 000 000 comparaisons

A noter qu'une formule en Sqr(x² + y²) donne des résultats relativement proches et n'est guère plus rapide (avec x = longitude * Cos(latitude) et y = latitude)

Effectuez une recherche sur Excel Downloads...

XL 2016 Affichage villes proches à partir coordonnées GPS

bobland974

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

erics83

XLDnaute Impliqué

job75

XLDnaute Barbatruc

erics83

XLDnaute Impliqué

Katido

XLDnaute Occasionnel

Katido

XLDnaute Occasionnel

Pièces jointes

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums