Insérer boucle dans programme VBA

Version imprimable

07/02/2016, 22h36
Stryke911

1 pièce(s) jointe(s)

Insérer boucle dans programme VBA

Bonjour à tous et à toutes,

J'ai récupéré une petite programmation sur le net (l'algorithme de Dijkstra pour les connaisseurs) que j'ai adapté à mes besoins.

Je souhaite savoir si vous pouviez m'aider à insérer une boucle à l’intérieur... tout simplement...

Mon programme vient du cheminement (cheminement = routing ou routage, si vous préférez) de câbles dans une grande installation électrique.
Ces derniers partent d'une armoire électrique vers une autre, en passant par quelques chemins de câbles (qui les supportent).
En bref, le programme fonctionne comme un GPS ; Je parts d'un point A et je veux aller au point B => le chemin le plus court est alors celui qui est généré.

Mon problème étant que cette programmation fonctionne au "coup par coup", c'est à dire "câble après câble". Dans les faits, j'ai une liste d'environ 500 câbles - ce qui me demande de répéter l'opération 500 fois. J'aimerais donc insérer une boucle automatique qui, lorsque je clique sur le calcul, fasse le même travail que précédemment, mais pour les 500 câbles.

Le programme :
Pièce jointe 200201

Exemple aujourd'hui :
Je saisi le tenant et l'aboutissant de mon câble : Armoire 1 => Armoire 2
Du coup, le chemin le plus court à emprunter est le suivant : A, B, C, E, H, U.
Et cela, je dois le répéter autant de fois que j'ai de câbles... alors qu'une boucle automatique permettrait de faire l'ensemble du travail en un seul clic.

Exemple de ce que je recherche ;
J'entre tous les tenants et tous les aboutissants (lignes après lignes) et le programme me donne le chemin correspondant à utiliser pour chacun d'entre eux
Armoire 1 => Armoire 2 ;
Armoire 3 => Armoire 1 ;
Armoire x => Armoire y ;
Armoire n => Armoire n+1 ;
etc.

et me génère le chemin pour chacun d'entre eux :
Armoire 1 => Armoire 2 ; A, B, C, E, H, U.
Armoire 3 => Armoire 1 ; H, K, I, O, P
Armoire x => Armoire y ; J, G, R, Y
Armoire n => Armoire n+1 ; I, P, N, C

Ca serait top que vous puissiez m'aider :)
Bonne journée

Il suffit de changer ta procédure AfficherResultat comme ceci:

Code:

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
Private Sub AfficherResultat(ByVal i As Long)Dim k As Variant
Dim n As Noeud
Dim iRow As Integer
 
 
With Feuil1
    .Range("R3:S10").ClearContents
    iRow = 2 + Chemin.NombreNoeuds
 
 
    For Each k In Chemin.Noeuds.Keys
        Set n = Chemin.Item(k)
        .Cells(iRow, "R").Value = n.Nom
        .Cells(iRow, "S").Value = n.Parcouru
        iRow = iRow - 1
    Next k
 
 
    .Range("R3:R10").Copy
    .Range("J20")(i).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Application.CutCopyMode = False
    With .Range("I20")(i)
        .Formula = "=SUM(S3:S7)"
        .Value = .Value
    End With
End With
End Sub

Et ta procédure CheminPlusCourt avec boucle:

Code:

1
2
3
4
5
6
7
8
9
Public Sub CheminPlusCourt()Dim i As Long
 
 
Initialisation
For i = 2 To 10                                       'TA BOUCLE
    AlgoDijkstra Feuil1.Range("H" & i), Feuil1.Range("I" & i)
    AfficherResultat i - 1
Next i
End Sub

il faudra bien sûr décaler ta plage résultats en bas et réadapter les plages du code

08/02/2016, 00h09
Stryke911

1 pièce(s) jointe(s)

Merci beaucoup, cela fonctionne!!

J'ai cependant une petite erreur, est-ce que vous sauriez ce que cela raconte ?
Erreur 424 - Objet requis

En cliquant sur le débogueur, j'ai la ligne suivante en surbrillance ;
Set debut = mesNoeuds.Item(nomNoeudDebut)

Nouvelle version du programme ;
Pièce jointe 200208

Cela m'intrigue ; le programme lui manque un objet mais tourne quand même ? Humm..

Ca n'a rien d’intrigant

Cette erreur vient du fait que tu as des nœuds vides ou nœuds n'existent pas dans la plage d'initialisation. D'où l'erreur.

Pour pallier à cela, j'ai ajouté une fonction et un test

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Public Sub CheminPlusCourt()
Dim i As Long
 
Initialisation
For i = 2 To 10   'TA BOUCLE
    If IsNoeud(Feuil1.Range("H" & i)) And IsNoeud(Feuil1.Range("I" & i)) Then
        AlgoDijkstra Feuil1.Range("H" & i), Feuil1.Range("I" & i)
        AfficherResultat i - 1
    End If
Next i
End Sub
 
Private Function IsNoeud(ByVal Tmp As String) As Boolean 'fonction qui test l'existence d'un noeud Tmp
 
On Error Resume Next
IsNoeud = Not mesNoeuds.Item(Tmp) Is Nothing
End Function

08/02/2016, 12h34
Stryke911

Merci énormément, cela fonctionne parfaitement !
Je vais continuer de travailler ce petit programme pour l'adapter à mon travail pro.
Merci encore !!
Bonne journée