Option Explicit
Dim Tableau(), Premier$, Point$, Ligne%, d As Object
Sub Choix_Tableaux()
Dim f As Worksheet, i&, l&
'Désactivation des applications.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
On Error GoTo Fin
Set f = Sheets("Test_4")
With f
l = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
.Range(.Cells(2, "E"), .Cells(l, "E")).Clear
For i = 2 To l
If .Cells(i, "D").Value <> "" Then
Création_Chemin f.Name, .Cells(i, "D").CurrentRegion, .Cells(i, "D"), .Cells(i, "D").CurrentRegion.Row
End If
Next i
.Columns(5).AutoFit
End With
'Désactivation des applications.
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Exit Sub
Fin:
MsgBox "Une erreur s'est produite ligne" & i, 16
'Désactivation des applications.
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Exit Sub
End Sub
Sub Création_Chemin(Feuille$, Temp As Range, Pre As Range, ii&)
Dim i%, j%
Set d = CreateObject("Scripting.Dictionary")
With Sheets(Feuille)
Premier = Pre.Value
Tableau = Temp.Resize(, 5).Value
'Permet de ne pas perdre de temps avec des réseaux d'une ligne
If UBound(Tableau) = 1 Then .Cells(ii, "E").Value = "Faux": Exit Sub
'On vérifie qu'il y a bien une valeur dans toutes les colonnes
For i = LBound(Tableau) To UBound(Tableau)
For j = 1 To 3
If Tableau(i, j) = "" Then
.Cells(ii, "E").Value = "Manque des informations"
.Cells(ii, "A").CurrentRegion.Interior.Color = 65535
Exit Sub
End If
Next j, i
Ecriture_Précédent Pre.Value, Pre.Offset(, -3).Value, 0
For i = 1 To UBound(Tableau)
If d.exists(Tableau(i, 2)) Then
d.Remove (Tableau(i, 2))
Tableau(i, 5) = "Faux"
End If
Next i
With .Cells(ii, "E").Resize(UBound(Tableau))
.NumberFormat = "@"
.Value = Application.Index(Tableau, Evaluate("Row(" & LBound(Tableau) & ":" & UBound(Tableau) & ")"), 5)
End With
End With
End Sub
Sub Ecriture_Précédent(Précédent, Point, Ligne)
Dim i%, a
For i = 1 To UBound(Tableau)
If Tableau(i, 2) = Précédent And Tableau(i, 3) <> Premier And Ligne <> i Then a = Tableau(i, 2): Tableau(i, 2) = Tableau(i, 3): Tableau(i, 3) = a
If Tableau(i, 3) = Précédent Then
d(Tableau(i, 3)) = ""
If Ligne = 0 Then
Tableau(i, 5) = Point
Else
Tableau(i, 5) = Tableau(Ligne, 5) & "-" & Tableau(i, 1)
End If
Ecriture_Précédent Tableau(i, 2), Tableau(i, 5), i
End If
Next i
End Sub