XL 2016 Affichage villes proches à partir coordonnées GPS

[bobland974]

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]

Bonjour le forum,

En fait on gagne bien plus de temps en testant la différence des latitudes par une formule simple :

    If Abs(Lat - t(j, 3)) * RT < dmax Then 'test sur les latitudes
      da = sinLat * Sin(t(j, 3)) + cosLat * Cos(t(j, 3)) * Cos(Lon - t(j, 4)) 'cosinus de la distance angulaire
      da = Atn(Sqr(Abs(1 - da ^ 2)) / da) 'distance angulaire en radian
      If da * RT < dmax Then

On ne fait pas la même chose avec les longitudes car il faudrait une formule complexe.

Le calcul préalable des sinus et cosinus ne fait plus gagner de temps, il n'est plus effectué.

La macro Calcul s'exécute maintenant en 4 min 37 s chez moi.

Pour la macro Classer on ne peut pas gagner de temps sur la Commande Convertir et le tri horizontal.

Fichier (5).

Bonne journée.

 

[job75]

Re,

Je ne le croyais pas mais la macro Classer est plus rapide en utilisant Quick sort :

Sub Classer()
Dim dur#, Ni&, i&, a, d!, vmax!, ville$, vmin&
dur = Timer
With Feuil2.[D2:D36467] 'plage à adapter éventuellement
  Ni = .Count
  For i = 1 To Ni
    If .Cells(i) <> "" Then
      a = Split(.Cells(i), "#")
      tri a, 0, UBound(a)
      .Cells(i, 0).Resize(, UBound(a) + 1) = a
      d = Val(Replace(.Cells(i), ",", "."))
      If d > vmax Then vmax = d: ville = Feuil1.Cells(i + 1, 1)
    End If
    If i Mod 100 = 1 Then Application.StatusBar = "Temps écoulé " & Format((Timer - dur) / 86400, "hh:mm:ss") & _
      "   Réalisé " & Format(i / Ni, "0.0 %") 'affichage de la progression dans la barre d'état
  Next i
  .Columns(0) = "=COUNTA(" & .Cells(1).Resize(, Columns.Count - 3).Address(0, 0) & ")" 'Nb villes proches
  vmin = Application.Min(.Columns(0))
End With
Application.StatusBar = ""
dur = (Timer - dur) / 86400
MsgBox "Durée du classement " & Minute(dur) & " min " & Second(dur) & " s" & vbLf & _
  "Nombre minimum de villes proches " & vmin & vbLf & _
  "Distance maximum de la ville la plus proche " & Format(vmax, "0.0") & " km pour " & ville
End Sub

Sub tri(a, gauc, droi)  ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(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

On gagne près d'une minute.

Fichier (6).

A+

 

[Dranreb]

Bonjour.
L'indexation par fusions bat celle par quick sort sur de gros volumes de données d'après mes essais.
En outre elle tire le meilleur parti possible de données déjà classées (aucun morcellement n'ayant été nécessaire) et d'ensembles déjà classées assemblés bout à bout.

 

[job75]

Bonjour Bernard, le forum,

Un nouveau gain de temps, important, sur la macro Calcul cette fois.

En triant préalablement le tableau sur les latitudes on simplifie le test sur les latitudes :

Dim flag As Boolean 'mémorise la variable (bloque la MsgBox de la macro RAZ)

Sub Calcul()
Dim dur#, RT#, dmax&, t, ub&, Ncombi&, resu$(), f$, i&, Lat#, Lon#, sinLat#, cosLat#, Latmax#, j&, combi&, da#, x$, n&
dur = Timer
RT = 6378.137 'rayon terrestre en km
dmax = Int(Val(Feuil1.[P1])) 'distance maximum retenue en km, cellule à adapter éventuellement
With Feuil1.[A1].CurrentRegion.Offset(1)
  If .Rows.Count = 1 Then Exit Sub
  .Sort .Columns(3), xlAscending, Header:=xlNo 'tri croissant sur les latitudes, pour accélérer
  t = .Resize(.Rows.Count - 1)
  ub = UBound(t)
  Ncombi = Application.Combin(ub, 2) 'nombre de distances à calculer
  '---tableau des résultats---
  ReDim resu(1 To ub, 1 To 1)
  f = String(Len(CStr(dmax)), "0") & ".0 k\m " 'format des distances
  For i = 1 To ub - 1
    Lat = t(i, 3): Lon = t(i, 4): sinLat = Sin(Lat): cosLat = Cos(Lat)
    Latmax = Lat + dmax / RT
    For j = i + 1 To ub
      If t(j, 3) > Latmax Then combi = combi + ub - j + 1: Exit For 'test sur les latitudes
      combi = combi + 1
      da = sinLat * Sin(t(j, 3)) + cosLat * Cos(t(j, 3)) * Cos(Lon - t(j, 4)) 'cosinus de la distance angulaire
      da = Atn(Sqr(Abs(1 - da ^ 2)) / da) 'distance angulaire en radian
      If da * RT < dmax Then
        x = Format(da * RT, f)
        resu(i, 1) = resu(i, 1) & x & t(j, 1) & "#"
        resu(j, 1) = resu(j, 1) & x & t(i, 1) & "#"
        If n Mod 10000 = 0 Then Application.StatusBar = "Temps écoulé " & Format((Timer - dur) / 86400, "hh:mm:ss") & _
          "   Réalisé " & Format(combi / Ncombi, "0.0 %") 'affichage de la progression dans la barre d'état
        n = n + 1
      End If
  Next j, i
  '---restitution---
  flag = True: Call RAZ: flag = False
  .Cells(1).Resize(ub, 2).Copy Feuil2.[A2]
  Feuil2.[D2].Resize(ub) = resu
  Feuil2.[A2].Resize(ub, 4).Sort Feuil2.[A2], xlAscending, Header:=xlNo, Orientation:=xlTopToBottom 'tri alphabétique
  Feuil2.Activate
  .Sort .Cells(1), xlAscending, Header:=xlNo 'tri alphabétique
End With
dur = (Timer - dur) / 86400
MsgBox "Nombre de distances retenues " & Format(n, "#,##0") & vbLf & "Durée du calcul " & Minute(dur) & " min " & Second(dur) & " s"
Application.StatusBar = ""
End Sub

La macro s'exécute en 2 min 6 s, maintenant ça devient compétitif.

Fichier (7).

Edit : Fichier (8) où les zéros non significatifs sont supprimés par la macro Classer, idem post #67.

Bonne journée.

 

[job75]

Bonsoir le forum,

Dans ce fichier on se fixe le nombre de villes proches (7, paramétrable).

Le fichier sera bien sûr beaucoup moins lourd.

A+

 

[job75]

Bonjour,

Un petit plus dans ce fichier (2), la suppression des zéros non significatifs :

      For j = 1 To IIf(ub1 < Nville, ub1, Nville)
        f = a(j)
        Do While Left(f, 1) = "0" 'suppression des zéros non significatifs
          If Not IsNumeric(Mid(f, 2, 1)) Then Exit Do
          f = Mid(f, 2)
        Loop
        resu(i, j) = f
      Next j

Ces zéros sont indispensables pour le tri mais tout à fait inutiles ensuite.

Je constate que la durée du classement n'est pas augmentée.

A+

 

[job75]

Bonjour le forum,

J'ai testé les 2 fichiers précédents sur mon 2ème ordi avec Excel 2010.

On gagne une dizaine de secondes sur chaque mesure des temps par rapport à Excel 2013.

Par ailleurs la barre d'état se bloque au bout de quelques secondes sur la partie classement.

Pour y remédier je viens d'ajouter un DoEvents.

Bon week-end.

 

[thierry b]

Bonjour a tous,
Je viens de prendre le forum suite a des recherches sur trouvé les villes proches
le dernier fichier de job75 et celui qui se rapproche le plus de ma recherche.
Sur la base de ce fichier, serait-il possible d'avoir un onglet où l'on peut faire une recherche pour 1 ville ou plusieurs selon notre choix sur une distance donner sans avoir le résultat de toutes les villes de la base de donner.
Serait-il possible de rajouter un critère de recherche sur la population par villes Ex: extraire les villes de -5000 habiter ou l'inverse extraire les villes de plus de 5000 Habt.

 

[erics83]

Bonjour le forum,

J'ai testé les 2 fichiers précédents sur mon 2ème ordi avec Excel 2010.

On gagne une dizaine de secondes sur chaque mesure des temps par rapport à Excel 2013.

Par ailleurs la barre d'état se bloque au bout de quelques secondes sur la partie classement.

Pour y remédier je viens d'ajouter un DoEvents.

Bon week-end.

Bonjour le forum et bonjour Job75,

Merci pour cet excellent fichier. Il permet effectivement d'avoir les villes dans un rayon de....

Je l'ai réduit au seul département du Var (les calculs sont donc extrêmement rapides). Cela fonctionne parfaitement !!
N'étant pas aussi cheuvrauné en VBA, j'ai mis une liste déroulante de choix : je sélectionne la ville, et grace à un INDEX/EQUIV, je "rapatrie" les villes dans le rayon donné....

Je suis alors dit, pourquoi pas sélectionner une ville, et lancer le cacul pour qu'il ne se fasse qu'à partir de cette ville ? ....

Mais....mes capacités et connaissances en VBA sont limitées.....je pense que tout est dans le

resu

, mais je ne sais pas comment le "récupérer" et/ou faire....

En fait, pour faire simple : on sélectionne la ville, on met le nombre d résultats souhaités + la distance, et en colonne J (ou autres), les villes apparaissent....

Merci pour votre aide,

(en PJ, le fichier de Job75 avec mes "ajouts" INDEX/EQUIV..., dont on pourrait se passer, c'est clair....lol)

 

[job75]

Bonjour erics83, le forum,

Pour ce que vous voulez faire il y a très peu de distances entre villes à calculer.

Il est donc totalement inutile d'utiliser la macro du post #66.

Voyez le fichier joint et cette macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$G$1" Then Exit Sub
Dim RT$, tablo, i As Variant, resu(), Lat, Lon, sinLat, cosLat, j&, da, n&
RT = 6378.137 'rayon terrestre en km
tablo = [A1].CurrentRegion.Resize(, 4)
i = Application.Match(Target, Columns(1), 0)
If IsNumeric(i) And UBound(tablo) > 2 Then
    ReDim resu(1 To UBound(tablo) - 2, 1 To 2)
    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
            n = n + 1
            resu(n, 1) = tablo(j, 1)
            resu(n, 2) = RT * da
        End If
    Next j
End If
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [G2] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n, 2) = resu
        .Resize(n, 2).Sort .Cells(1, 2), xlAscending, Header:=xlNo 'tri sur les distances
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

Elle s'exécute automatiquement quand on choisit une ville dans la liste de validation en G1.

Nota : sur mon ordi actuel avec Win 11 et Excel 2019 les durées d'exécution pour la macro du post #66 sont de 46 secondes et 28 secondes, la technique a évolué.

A+

 

[erics83]

Bonjour erics83, le forum,

Pour ce que vous voulez faire il y a très peu de distances entre villes à calculer.

Il est donc totalement inutile d'utiliser la macro du post #66.

Voyez le fichier joint et cette macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$G$1" Then Exit Sub
Dim RT$, tablo, i As Variant, resu(), Lat, Lon, sinLat, cosLat, j&, da, n&
RT = 6378.137 'rayon terrestre en km
tablo = [A1].CurrentRegion.Resize(, 4)
i = Application.Match(Target, Columns(1), 0)
If IsNumeric(i) And UBound(tablo) > 2 Then
    ReDim resu(1 To UBound(tablo) - 2, 1 To 2)
    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
            n = n + 1
            resu(n, 1) = tablo(j, 1)
            resu(n, 2) = RT * da
        End If
    Next j
End If
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [G2] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n, 2) = resu
        .Resize(n, 2).Sort .Cells(1, 2), xlAscending, Header:=xlNo 'tri sur les distances
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

Elle s'exécute automatiquement quand on choisit une ville dans la liste de validation en G1.

Nota : sur mon ordi actuel avec Win 11 et Excel 2019 les durées d'exécution pour la macro du post #66 sont de 46 secondes et 28 secondes, la technique a évolué.

A+

Merci Job75,

Effectivement, c'est extrêmement rapide et efficace !!! et correspond presque à ce que je cherchais, car j'"aimais" bien le choix du rayon dans votre précédent fichier, je trouvais cela intéressant d'avoir le nom des villes dans un périmètre de x kilomètres...Ce n'est plus possible ?

Et toute dernière "sollicitation", serait il possible de mettre le choix dans un USF : dans le USF on a un combobox de choix de ville, un combobox de rayon, et la liste des ville apparait dans une listbox (ou combobox) au lieu de [G2] ? Mes connaissances en VBA ne sont pas très développées.... MERCI pour votre aide,

En vous remerciant par avance,
Eric

 

[job75]

j'"aimais" bien le choix du rayon dans votre précédent fichier, je trouvais cela intéressant d'avoir le nom des villes dans un périmètre de x kilomètres...Ce n'est plus possible ?

Bien sûr que c'est possible, il suffit d'ajouter un test :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [G1,K1]) Is Nothing Then Exit Sub
Dim RT$, daMax, tablo, i As Variant, resu(), Lat, Lon, sinLat, cosLat, j&, da, n&
RT = 6378.137 'rayon terrestre en km
daMax = [K1] / RT 'distance angulaire max
tablo = [A1].CurrentRegion.Resize(, 4)
i = Application.Match([G1], Columns(1), 0)
If IsNumeric(i) And UBound(tablo) > 2 Then
    ReDim resu(1 To UBound(tablo) - 2, 1 To 2)
    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
                n = n + 1
                resu(n, 1) = tablo(j, 1)
                resu(n, 2) = RT * da
            End If
        End If
    Next j
End If
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [G2] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n, 2) = resu
        .Resize(n, 2).Sort .Cells(1, 2), xlAscending, Header:=xlNo 'tri sur les distances
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

Quant à l'UserForm ça complique inutilement les choses, je vous laisse essayer c'est un bon exercice.

 

[erics83]

Bien sûr que c'est possible, il suffit d'ajouter un test :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [G1,K1]) Is Nothing Then Exit Sub
Dim RT$, daMax, tablo, i As Variant, resu(), Lat, Lon, sinLat, cosLat, j&, da, n&
RT = 6378.137 'rayon terrestre en km
daMax = [K1] / RT 'distance angulaire max
tablo = [A1].CurrentRegion.Resize(, 4)
i = Application.Match([G1], Columns(1), 0)
If IsNumeric(i) And UBound(tablo) > 2 Then
    ReDim resu(1 To UBound(tablo) - 2, 1 To 2)
    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
                n = n + 1
                resu(n, 1) = tablo(j, 1)
                resu(n, 2) = RT * da
            End If
        End If
    Next j
End If
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [G2] '1ère cellule de destination, à adapter
    If n Then
        .Resize(n, 2) = resu
        .Resize(n, 2).Sort .Cells(1, 2), xlAscending, Header:=xlNo 'tri sur les distances
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub

Quant à l'UserForm ça complique inutilement les choses, je vous laisse essayer c'est un bon exercice.

Merci Job75,

Le USF, c'était vraiment pour "simplifier" : on clique et on ne "voit" que le USF....et le résultat.

Je vais essayer.....apparemment, il faudrait que je remplace le choix [G1] par une combobox, idem pour [K1], et que ensuite, j'affiche

.Resize(n, 2).Sort .Cells(1, 2), xlAscending, Header:=xlNo 'tri sur les distances

dans une listbox....
Je comprends la logique, mais....je ne suis pas certain d'y arriver.......

Merci pour votre aide, et merci pour ce code
Eric,

 

[job75]

En fait il s'agit de filtrer une base de données avec un UserForm.

Il y a de très nombreux exemples sur ce forum.

 

[erics83]

En fait il s'agit de filtrer une base de données avec un UserForm.

Il y a de très nombreux exemples sur ce forum.

Merci Job75 pour votre réponse,

mais je ne comprends pas la notion de "filtrer" dans un USF....

La base de donnée est créé grâce à votre code, il faudrait que je puisse la "récupérer" dans une listbox.....mais depuis tout à l'heure, je n'y arrive pas.....

Merci pour votre aide,
Eric