XL 2019 Code VBA distance entre cellules

[Roro9876543210]

Bonjour,

Je débute sur VBA et je dois effectuer un programme qui me parait complexe. A partir d'une carte (ci dessous) avec plusieurs points, je dois calculer la distance entre chaque point en faisant un tableau (ci dessous). J'ai vraiment aucune idée pour effectuer cela. Pourriez - vous m'aider ?

Merci

 

[mapomme]

Bonjour @Roro9876543210 et bienvenue sur XLD ,

Joindre un petit fichier plutôt que des images serait grandement apprécié

A+

 

[Dranreb]

Bonsoir.
Vrai, ça, quoi, pas sympa de nous obliger à taper les donnée dans un nouveau classeur.
M'enfin voilà :

Sub Distances()
   Dim TCarte(), L As Long, C As Long, TY(1 To 12) As Long, _
      TX(1 To 12) As Long, N As Long, TDist(0 To 12, 0 To 12)
   TCarte = ActiveSheet.[A1:I10].Value
   For L = 1 To UBound(TCarte, 1)
      For C = 1 To UBound(TCarte, 2)
         N = TCarte(L, C): If N > 0 Then TX(N) = C: TY(N) = L
         Next C, L
   For L = 1 To 12: TDist(L, 0) = L: TDist(0, L) = L: Next L
   For L = 2 To 12: For C = 1 To L - 1
      TDist(L, C) = Sqr((TX(C) - TX(L)) ^ 2 + (TY(C) - TY(L)) ^ 2)
      TDist(C, L) = TDist(L, C)
      Next C, L
   ActiveSheet.[K1].Resize(13, 13).Value = TDist
   End Sub

Ce qui me fait marrer c'est que si c'est un exercice demandé par un prof et que vous lui présentez ça, il saura tout de suite que ce n'est pas vous qui l'aurez fait
À moins que vous vous arrangiez pour savoir répondre à toutes les questions qu'il pourrait vous poser !

 

[mapomme]

Bonjour @Roro9876543210,

Une version par formules...

 

[jmfmarques]

Bonjour à tous
A Dranreb :

il saura tout de suite que ce n'est pas vous qui l'aurez fait
À moins que vous vous arrangiez pour savoir répondre à toutes les questions qu'il pourrait vous poser !

C'est exactement ce qui est arrivé il y a environ 7 ans à un groupe de stagiaires du gouvernement fédéral, à OTTAWA.
Et les conséquences ne se sont pas arrêtées à des sanctions infligées à ces seuls stagiaires ...

 

[mapomme]

Re,

Avec une fonction personnalisée (donc en VBA): Distance(tablo As Range, Point1, Point2)

• tablo est la plage source sans les en-têtes
• Point1 est un premier nombre ou une cellule contenant un nombre
• Point2 est un second nombre ou une cellule contenant un nombre
• Distance renvoie la distance entre le point 1 et le point 2 dans le tableau source

Le code de la fonction Distance(...) :

Function Distance(tablo As Range, Point1, Point2)
Dim x1 As Range, x2 As Range
   Distance = "-"
   If Not IsNumeric(Point1) Or Not IsNumeric(Point2) Then Exit Function
   If Application.CountIf(tablo, Point1) <> 1 Then Exit Function
   If Application.CountIf(tablo, Point2) <> 1 Then Exit Function
   If Point1 = Point2 Then Distance = "": Exit Function
   For Each x1 In tablo
      If x1 = Point1 Then Exit For
   Next x1
   For Each x2 In tablo
      If x2 = Point2 Then Exit For
   Next x2
   Distance = Sqr((x1.Row - x2.Row) ^ 2 + (x1.Column - x2.Column) ^ 2)
End Function

Edit: pour l'enseignement à distance (ENT), voila le code commenté:

Function Distance(tablo As Range, Point1, Point2)
Dim x1 As Range, x2 As Range     'x1 et x2 sont des variables destinées à référencer une cellule
   'valeur par défaut de la fonction Distance
   Distance = "-"
   'si Point1 n'est pas numérique ou si Point2 n'est pas numérique,
   'on quitte la fonction en gardant la valeur par défaut
   If Not IsNumeric(Point1) Or Not IsNumeric(Point2) Then Exit Function
   ' on compte le nombre de valeur de Point1 dans la plage source tablo
   ' c'est la fonction NB.SI() mais en anglais (VBA cause américain)
   ' Point1 doit apparaitre une et une seule fois dans le tableau
   ' sinon on quitte la fonction en gardant la valeur par défaut
   If Application.CountIf(tablo, Point1) <> 1 Then Exit Function
   ' Idem pour le Point2
   If Application.CountIf(tablo, Point2) <> 1 Then Exit Function
   ' A ce stade, on est certain que Point1 et Point2 sont dans le tableau
   ' si le Point1 est égal au Point2, alors la distance est nulle et on quitte
   ' après avoir affecté la chaine vide à la fonction
   If Point1 = Point2 Then Distance = "": Exit Function
   ' on fait une boucle sur chaque cellule de la plage tablo
   ' si la valeur de la cellule est la valeur de Point1,
   ' alors on sort de la boucle et x1 est donc la cellule du premier point
   For Each x1 In tablo
      If x1 = Point1 Then Exit For
   Next x1
   ' Idem pour le Point2
   For Each x2 In tablo
      If x2 = Point2 Then Exit For
   Next x2
   ' à ce stade, on connait les deux cellules x1 et x2 correspondant à Point1 et à Point2
   ' on applique le théorème de Pythagore à:
   ' la distance verticale séparant les deux points: X=  x1.Row - x2.Row
   ' la distance horizontale séparant les deux points:Y=  x1.Column - x2.Column
   ' distance = racine carrée de (X^2 +Y^2)
   Distance = Sqr((x1.Row - x2.Row) ^ 2 + (x1.Column - x2.Column) ^ 2)
End Function

 

[Roro9876543210]

Merci Beaucoup pour votre investissement, le programme fonctionne.
Je préciserai que j'ai eu de l'aide pour cette partie mais que j'arrive à la comprendre grâce à vous .