Distancier

[svdb]

Bonjour,

Dans le fichier joint vous trouverez mon dossier de travail.
Dans la feuille 1 se sont les communes avec leurs codes postaux
Dans la feuille 2 je souhaiterai réaliser un distancier ayant cette forme là mais impossible d'y arriver (même avec les macros déjà présentées sur le forum)
Quelqu'un peut-il m'aider à trouver la macro nécessaire pour remplir les case ?

Merci

 

[KenDev]

Re : Distancier

Bonjour Svdb,

Trouver une macro qui calcule la distance entre deux villes avec comme tableau de données juste leur code postal ? je suis pessimiste... Peut-être avec le prénom du maire de la commune ?
Taquineries mis à part, ou sont les données sources nécessaires à ce calcul ? Genre latitude-longitude pour chaque ville ?
Cordialement

KD

 

[Softmama]

Re : Distancier

Bonjour,

macro qui vaut pas grand chose, mais qui remplit les cases... en attendant mieux !

Sub test()
Dim IE As New InternetExplorer
Dim Doc As HTMLDocument, D As String
Dim nbVil As Integer
Set IE = New InternetExplorer
    nbVil = Application.CountA(Range("A:A"))
    For t = 1 To nbVil
        For u = 1 To nbVil
            IE.navigate "http://fr.distance24.org/" & Cells(c.Row, 1) & "/" & Cells(1, c.Column)
            Do While IE.Busy Or IE.readyState = READYSTATE_LOADING: DoEvents: Loop
            Set Doc = IE.document
            D = Doc.body.innerText
            Cells(t + 1, u + 1) = Mid(D, InStr(D, " est de ") + 8, InStr(D, " kilomètres.") - InStr(D, " est de ") - 8)
        Next u
    Next t
Set IE = Nothing
End Sub

cf. fichier joint

 

[JCGL]

Re : Distancier

Bonjour à tous,

En espérant que nos propositions ne seront pas vendues...
Je ne trouve pas les mêmes distances que SoftMama (il semblerait que ses distances soient "des vols d'oiseau")

A + à tous

 

[KenDev]

Re : Distancier

Bonjour Svdb, Masterdico, Softmama, JCGL,

Sans accès internet, mais après avoir récupéré une liste des communes avec latitude/longitude, une solution 'vol d'oiseau' par macro utilisant une formule trouvée ici : Calculate distance and bearing between two Latitude/Longitude points using Haversine formula in JavaScript.

Je transmet un xlsm car j'ai 489 communes donc 490 colonnes. Si pas de possibilité de l'ouvrir, les communes sont en colonne A, les latitudes en colonne C, les longitudes en colonne D (feuille Data). La feuille receveuse (Dst33) est vide au départ.

Cordialement

KD

Option Explicit

Function Dst#(Lat1#, Lng1#, Lat2#, Lng2#)
'formule : [url=http://www.movable-type.co.uk/scripts/latlong.html]Calculate distance and bearing between two Latitude/Longitude points using Haversine formula in JavaScript[/url]
    Dim R As Long
    R = 6371
    Lat1 = Lat1 / 180 * WorksheetFunction.Pi()
    Lng1 = Lng1 / 180 * WorksheetFunction.Pi()
    Lat2 = Lat2 / 180 * WorksheetFunction.Pi()
    Lng2 = Lng2 / 180 * WorksheetFunction.Pi()
    If Lat1 = Lat2 And Lng1 = Lng2 Then
        Dst = 0
    Else
        Dst = Round(WorksheetFunction.ACos(Sin(Lat1) * Sin(Lat2) + Cos(Lat1) * Cos(Lat2) * Cos(Lng2 - Lng1)) * R, 3)
    End If
End Function

Sub Distancier()
Dim w1 As Worksheet, w2 As Worksheet, i&, j&, n&
    Application.ScreenUpdating = False
    Set w1 = Worksheets("Data"): Set w2 = Worksheets("Dst33")
    For i = 2 To w1.Cells(Rows.Count, 1).End(xlUp).Row
        n = n + 1
        w2.Cells(n + 1, 1) = w1.Cells(i, 1)
        w2.Cells(1, n + 1) = w1.Cells(i, 1)
    Next i
    For i = 2 To w2.Cells(Rows.Count, 1).End(xlUp).Row
        For j = 2 To w2.Cells(Rows.Count, 1).End(xlUp).Row
            If i = j Then
                w2.Cells(i, j) = 0
            Else
                w2.Cells(i, j) = Dst(w1.Cells(i, 3), w1.Cells(i, 4), w1.Cells(j, 3), w1.Cells(j, 4))
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub