Discussion :

[peshko60]

Bonjour,

Tout d'abord je tiens à m'excuser si jamais cette question a déjà été posée (j'ai parcouru les différents sujets mais je n'ai pas trouvé ce que je cherchais).

Je dois gérer une nomenclature technique complexe (environ 12 000 liens) qui se compose visuellement comme suit :

Article A
Article B
Articl C
Article F
Articl D
Article E

Et qui signifie que C est le fils de B qui est le fils de A etc.
Dans la base de données les données sont stockées dans deux colonnes (A et B) :

Article C Article B
Article B Article A
Article F Article A
Article E Article D

Je souhaiterais trouver le dernier père pour chaque article. Dans mon exemple le dernier père de l'article C est l'article A.

Un article peut avoir 10 pères au maximum.

Ainsi, je souhaiterais que les colonnes C à L soient resnsegnées avec la valeur de la colonne B qui correspond au dernier père de la colonne A, soit :

Article C Article B Article A
Article B Article A Article A
Article F Article A Article A

Je suppose que cela passe par des boucles Do While et For Each mais je n'arrive pas à créer cette macro.

je vous remercie par avance de votre aide.

Cordialement

[jp014]

Bonjour

Ci dessous un code à tester et à améliorer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
 
Option Explicit
Dim tablo() As String
Dim code1() As String
Dim code2() As String
Dim i As Byte
 
Sub travdem()
Dim cellule As Range
Dim nomfeuille1 As String
Dim lig As Long
 
' pour boucler sur la colonne 1
 
nomfeuille1 = "Feuil1"
 
With Sheets(nomfeuille1)
For Each cellule In .UsedRange.Columns(1).Cells
    cellule.Offset(0, 1) = cellule & " "
    If cellule <> "" Then
    tablo() = Split(cellule, " ")
    Call decomp(1)
        If code1(1) <> "" Then
        lig = rechercheligne(nomfeuille1, "a", code1(1), cellule.Row + 1)
        If lig > 0 Then
        cellule.Offset(0, 1) = cellule.Offset(0, 1) & "Article" & " " & code1(1)
        End If
        End If
    End If
Next cellule
End With
End Sub
 
 
'----------------------------------------------
'
 
Private Function rechercheligne(£feuille As String, £colonne As String, £dataf As String, £depart As Long)
Dim £dataf1 As String
Dim £if1 As Integer
Dim £if2 As Long, £dl1 As Long
Dim £cell As Range
 
With Sheets(£feuille)
£dl1 = .Range(£colonne & Rows.Count).End(xlUp).Row
If £depart <= £dl1 Then
 
    For Each £cell In .Range(£colonne & £depart & ":" & £colonne & £dl1)
        tablo() = Split(£cell, " ")
        Call decomp(2)
        If code2(0) = £dataf Then
            rechercheligne = £cell.Row
            Exit Function
        End If
 
    Next £cell
  rechercheligne = 0
 End If
 End With
End Function
' décomposition du texte pour mettre en évidence les codes
' val1 sert simplement à indiquer la variable pour la réponse
Private Sub decomp(val1 As Byte)
Dim j As Byte
Dim data1 As String
j = 0
i = LBound(tablo)
data1 = ""
Do
If tablo(i) = "Article" Then
    If data1 = "" Then
        data1 = tablo(i + 1)
    Else
        data1 = data1 & "/" & tablo(i + 1)
    End If
 
End If
i = i + 1
If i > UBound(tablo) Then Exit Do
Loop
If val1 = 1 Then code1() = Split(data1, "/")
If val1 = 2 Then code2() = Split(data1, "/")
End Sub

JP014

[peshko60]

Merci beaucoup pour cette aide.

Néanmoins, lorsque je lance le code j'ai une erreur d'exécution n°9 et a priori il s'arrête à la première ligne.

malheureusement, le code est trop compliqué pour moi et je n'arrive pas à le comprendre.

Je joins un fichier simple, les données sont dans les deux premières colonnes et le résultat voulu est dans les colonnes suivantes.

[LeForestier]

Bonjour,
Je ne comprend pas ce que tu veux dire
Et si jp014 à compris , il manque les redim dans sont code.
A+

[jp014]

Bonjour peshko60
Bonjour LeForestier



La procédure est basé sur les données indiquées
Article C Article B
Article B Article A
Article F Article A
Article E Article D

Le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

tablo() = Split(cellule, " ")

Permet d'extraire les nom des articles à savoir la deuxième et quatrième position.
J'ai loupé la phrase
"Dans la base de données les données sont stockées dans deux colonnes (A et B)"

Concernant le fichier envoyé je n'ai pas compris la structure des données.



JP014

[Pierre Fauconnier]

Bonjour.

Je propose de travailler avec une classe perso, car elle permet une hiérarchisation sans devoir se préoccuper du nombre de niveaux.

Présupposé: Chaque article doit se trouver une seule fois en colonne A, même celui qui n'a pas de parent (A par exemple). En B, on trouve soit le code de l'article parent, soit rien (article orphelin).

Ce présupposé est à mon sens obligatoire et incontournable.

Après, on crée une classe perso cArticle possédant deux propriétés:
Numero, qui reprend le numéro de l'article de type String
Parent, de type cArticle qui contiendra l'article parent s'il existe

Pour cela, il faut créer un module de classe, le nommer cArticle et placer le code suivant (C'est une classe très simple)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Option Explicit
 
Public Numero As String
Public Parent As cArticle

Après, on boucle une première fois pour charger une collection avec les articles en A (une fois chaque article, donc).

On boucle une deuxième fois pour charger les parents. Boucler en deux étapes pour charger les articles et leurs parents évite de passer par une procédure récursive. De plus, comme on a chargé chaque article dans collection à la boucle 1, on est certain que si parent il y a, il est chargé dans la collection

On boucle une troisième fois pour décharger chaque parent tant qu'il y en a, chaque parent étant lui-même le fils de son père, s'il n'est pas orphelin. S'il est orphelin, on passe à l'article suivant.

Voici la procédure à utiliser dans un module standard. Elle est à adapter en fonction de tes besoins.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
28
29
30
31
32
33
34
35
Sub Arborescence()
    Dim oCollection As New Collection
    Dim Cellule As Range
    Dim oArticle As cArticle
    Dim oParent As cArticle
    Dim Colonne As Integer
 
    ' Chargement de chaque article dans la collection
    For Each Cellule In Range(Range("a2"), Range("a" & Rows.Count).End(xlUp))
        Set oArticle = New cArticle
        oArticle.Numero = Cellule.Value
        oCollection.Add oArticle, oArticle.Numero
    Next Cellule
 
    ' Attribution de l'article parent à chaque article, si l'article n'est pas orphelin
    For Each Cellule In Range(Range("a2"), Range("a" & Rows.Count).End(xlUp))
        Set oArticle = oCollection.Item(Cellule.Value)
        If Cellule(1, 2) <> "" Then
            Set oParent = oCollection.Item(Cellule(1, 2))
            ' Chaque parent devient article pour permettre l'extraction de son père
            Set oArticle.Parent = oParent
        End If
    Next Cellule
 
    ' Chaque parent devient à son tour article pour remonter d'un niveau dans l'arbre
    For Each Cellule In Range(Range("a2"), Range("a" & Rows.Count).End(xlUp))
        Colonne = 3
        Set oArticle = oCollection.Item(Cellule.Value)
        Do While Not oArticle.Parent Is Nothing
            Cellule(1, Colonne) = oArticle.Parent.Numero
            Set oArticle = oArticle.Parent
            Colonne = Colonne + 1
        Loop
    Next Cellule
End Sub

Cette solution met en lumière un travail avec une classe perso et une collection.
Complément d'info sur les classes perso

[jp014]

Bonjour

Ci dessous la procédure modifiée

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Option Explicit
Dim i As Byte, j As Byte
 
Sub travdem()
Dim cellule As Range
Dim nomfeuille1 As String
Dim lig As Long
Dim data1 As String
' pour boucler sur la colonne 1
 
nomfeuille1 = "Feuil2"
 
With Sheets(nomfeuille1)
For Each cellule In .UsedRange.Columns(1).Cells
 
    data1 = cellule.Offset(0, 1)
    If cellule <> "" Then
        i = 1
        j = 2
        Do
 
            lig = rechercheligne(nomfeuille1, "a", data1, 2, cellule.Row)
            If lig = 0 Then Exit Do
            If lig > 0 Then
                cellule.Offset(0, j) = .Cells(lig, 2)
                i = i + 1
                j = j + 1
                data1 = .Cells(lig, 2)
            End If
            If data1 = "" Then Exit Do
        Loop
    End If
Next cellule
End With
End Sub
 
 
'----------------------------------------------
'
 
Private Function rechercheligne(£feuille As String, £colonne As String, £dataf As String, £depart As Long, £celencours As Long)
Dim £dataf1 As String
Dim £if1 As Integer
Dim £if2 As Long, £dl1 As Long
Dim £cell As Range
 
With Sheets(£feuille)
£dl1 = .Range(£colonne & Rows.Count).End(xlUp).Row
If £depart <= £dl1 Then
 
    For Each £cell In .Range(£colonne & £depart & ":" & £colonne & £dl1)
        If £celencours <> £cell.Row Then
            If £cell = £dataf Then
                rechercheligne = £cell.Row
                Exit Function
            End If
        End If
    Next £cell
  rechercheligne = 0
 End If
 End With
End Function

La recherche se fait a partir de la ligne2.
Ci joint des images, avant de lancer la procédure, et après.

A tester

JP014