[XL-2007] Simplifier le code (diminuer le temps de calcul) d'une base de données de références composants

[RicoExo]

Bonjour,

Je suis chargé par ma société de mettre au point un fichier (Excel) gérant une base de données des références pièces du produit que nous concevons.

• Cette base de données permet aux utilisateurs de rentrer des pièces auxquelles sont attribuées automatiquement une référence en fonction de leur type (mécanique, doc, électrique, …). Les utilisateurs doivent liés la pièce qu’il s’apprête à s’insérer à au moins un assemblage parent direct (par exemple telle pièce appartient à tel assemblage).
• Le fichier doit de plus permettre de pouvoir modifier certaines choses (changement de variantes, changement de révision, de quantité par assemblage, d’assemblages parents, la suppression partielle/totale, …)
• Enfin il doit permettre aussi une lecture seule de la BDD ainsi que de voir les liens entre les composants et assemblages.

Voilà pour expliquer le fichier joint (servez-vous pour ceux qui veulent l’utiliser pour eux !).

Maintenant mon problème est celui-ci : lorsqu’une modification est faite dans la BDD, je voudrais qu’il y ait une information sur la date de la modification et le nom de l’utilisateur (apparaissent dans les deux dernières colonnes dans l’onglet « Périmètre ») responsable à cette pièce mais aussi aux assemblages qui comprennent cette pièce ainsi que les assemblages qui comprennent ceux-ci et ainsi de suite.

Ma fonction VB répondant à ce problème marche (voir code dans modules « RechMAJModif » et « MAJModif » dans le fichier) mais elle est très lourde et plus il y a de pièces rentrées, plus le temps d’opérations est long (plusieurs minutes pour près de 200 entrées pour l’instant et il y aura près de 1000 entrées). J’ai mis en commentaire ces deux fonctions, il suffit de les remettre en code pour faire marcher cette fonction en faisant une modification avec les boutons de la page « accueil » appropriés.
Les onglets n’apparaissent pas volontairement pour que l’utilisateur soit obligé de cliquer sur les boutons afin de travailler sur le fichier. Ils peuvent bien sur être affiché par les options d’Excel.

Ma question est de savoir si quelqu’un pouvait m’aider à alléger le code afin que le temps de calcul soit réduit à quelques secondes.

Concrètement le code est conçu de la façon suivante : dans la feuille « TableRelation » la fonction va chercher les assemblages parents directs (colonne 3) de la pièce concernée (colonne 1) et mettre les informations date et nom user à jour dans la feuille « Périmètre » où ils sont présents. Ensuite cette étape recommence mais maintenant ce sont ces références-ci (qui sont dans la colonne 1) pour lesquelles on va chercher leurs assemblages parents et mettre à jour les informations et ainsi de suite jusqu’à l’assemblage maitre qui est 9000001.

Si un mot de passe est demandé c’est « QUALITY ». Comme il y a un grand nombre d’informations dans le fichier et que je ne suis pas sur d’avoir été très clair, je me tiens bien sur à disposition pour répondre aux questions plus spécifiques. Un fichier word « How-to » destiné aux utilisateurs de ma société existe si cela peut vous aider, je pourrais le joindre ultérieurement.

Merci d’avance !!

20111107_BDD-referencement_FINAL.zip

[Daniel.C]

Bonsoir,

Concrètement, il faut faire quoi pour déclencher l'exécution de la macro ? En l'exécutant depuis la fenêtre VBE, l'exécution est instantanée.

[RicoExo]

Bonjour,

Je n'avais pas vu votre message, désolé pour le temps de réponse! La fonction qui prend du temps est mise en commentaire et donc inactive.
Pour l'activer il suffit de remettre en "code" les module RechMAJModif et MAJModif.

Cordialement,

Eric

[Daniel.C]

Bonjour,

"RechMAJModification" est une macro, pas une fonction. Si je la lance, l'exécution est instantanée. Comment doit-on procéder pour la lancer ?

[Qwazerty]

Salut

Sans être rentré dans les détails du fonctionnement, voila quelques modifs.
A mon avis pour vraiment améliorer le temps de traitement, il faut travailler avec des tableaux.

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
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
Sub RechMAJModification()
 
'Toujours mettre au moins une majuscule dans les noms de variables, ca permet de repérer les fautes de frappe dans le code
'il faut répeter les type des variables à chaque fois, sinon VB déclare des variants
Dim Plage6 As Range, ChercheIni As Range, Cherch As Range, Cherch2 As Range, Cell As Range
Dim i As Integer, j As Integer, l As Integer, k As Integer, m As Integer, n As Integer, o As Integer
'
Dim SheetRelation As Worksheet
 
'Il est préférable de faire référence à un onglet en précisant dans quel classeur il se trouve
'L'utilisation de variable worksheet alége ensuite le code
Set SheetRelation = ThisWorkbook.Sheets("TableRelation")
j = 0
k = 1
l = SheetRelation.Cells(Rows.Count, "A").End(xlUp).Row
'
'
'
With ThisWorkbook.Sheets("Périmètre")
    Set Plage6 = .Range("N3", .Cells(.Rows.Count, "I").End(xlUp).Offset(0, 5)) 'la colonne N est vide?
End With
    ''MsgBox (plage6.Address)
    'Attention a l'orthographe des variables "cherchEini"
    Set ChercheIni = Plage6.Find("1", LookIn:=xlValues, SearchDirection:=xlNext)
    '
    If Not ChercheIni Is Nothing Then
        With ThisWorkbook.Sheets("vba2")
        '    'MsgBox (cherchini.Offset(0, -5).Value)
            .Range("A1").Value = ChercheIni.Offset(0, -5).Value
 
            While n <> 0 '"0" n est de type integer pas de type string
                j = j + 1
                'i = 0
                    For i = 0 To l
                        n = Application.CountA(.Range(.Cells(j, "A"), .Cells(j, .Columns.Count).End(xlToLeft)))
                        o = Application.CountA(.Range(.Cells(j + 1, "A"), .Cells(j + 1, .Columns.Count).End(xlToLeft)))
                        For m = 1 To n
                            Set Cherch = SheetRelation.Range(SheetRelation.Cells(i, 1), SheetRelation.Cells(l, 1)).Find(.Cells(j, m).Value, LookIn:=xlValues, SearchDirection:=xlNext)
                            If Not Cherch Is Nothing Then
                                k = Cherch.Row
                                Set Cherch2 = .Range(Sheets("vba2").Cells(j + 1, 1), .Cells(j + 1, 1000)).Find(SheetRelation.Range(cel(k)).Value, LookIn:=xlValues, SearchDirection:=xlNext)
                                If Cherch2 Is Nothing Then
                                    .Cells(j + 1, o + 1) = SheetRelation.Range(cel(k)).Value
                                End If
                            End If
                        Next m
                    Next i
            Wend
        End With
    'End If
    '
'MAJModification
'
'Sheets("vba2").Cells.Clear
'
'plage6.Clear
'
 
 
End Sub

Peux tu expliquer ce que devrait contenir la feuille VBA2, qui est vide dans ton fichier.
++
Qwaz

Salut

J'ai du mal à retrouver mes petits dans ton code.

Voila ce que je te propose

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
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
Sub testeListeArbo()
ListeArbo "9000018"
 
End Sub
 
Sub ListeArbo(Ref As String)
'On va dresser l'arborescence d'un composant (arbre généalogique du composant)
Dim SheetRelation As Worksheet, SheetPerim As Worksheet
Dim ArbreGene As String
Dim CellFind As Range
Dim LookForRef As String
Dim Tab_Ref As Variant
Dim TheRef As Variant
 
'init
Set SheetRelation = ThisWorkbook.Sheets("TableRelation")
Set SheetPerim = ThisWorkbook.Sheets("Périmètre")
LookForRef = Ref
 
'On place notre ref dans l'arbre
ArbreGene = LookForRef
 
Do
    'Init CellFind pour effacer la valeur de la boucle précedente
    Set CellFind = Nothing
    'On recherche le parent de la ref dans la liste
    Set CellFind = SheetRelation.Columns("A").Find(LookForRef, LookIn:=xlValues)
 
    If CellFind Is Nothing Then
        'probleme ref inconnu
    Else
        'On pointe notre nouvelle ref qui sera recherchée au prochain tour
        LookForRef = CellFind.Offset(0, 2).Value
        'on ajoute le parent dans la liste
        If LookForRef <> "" Then ArbreGene = ArbreGene & ";" & LookForRef
    End If
    'On recherche le composant en amont jusqu'a trouver le composant maitre ou si un composant n'a pas de parent
Loop Until (LookForRef = "") Or (LookForRef = "9000001") Or (CellFind Is Nothing)
 
'Si on sort de la boucle parce que LookRef = "", il faudra gérer le problème
If LookForRef = "" Then
    'A toi de voir
End If
 
'On place les ref obtenues dans un tableau
Tab_Ref = Split(ArbreGene, ";")
 
'On met ensuite à jour les dates des composants présants dans la liste
For Each TheRef In Tab_Ref
    'On recherche la ref dasn la seuille Périmètre
    Set CellFind = SheetPerim.Columns("I").Find(TheRef, LookIn:=xlValues)
 
    If Not CellFind Is Nothing Then
        'On met a jour la date et le User
        CellFind.Offset(0, 3).Value = Format(Date, "dd/mm/yyyy")
        CellFind.Offset(0, 4).Value = Application.UserName
    End If
Next
 
End Sub

Ici, on dresse la liste des éléments ayants un rapport avec le composant initial puis on met a jour les date de modif et utilisateur/modifieur.

++
Qwaz

[RicoExo]

Tout d'abord, je tiens à vous remercier Daniel.C et Qwazerty pour votre aide!

Pour répondre à vos questions:

@Daniel. C : pour faire marcher la macro, il faut enlever les commentaires qui désactivent le code dans les deux modules cités. Ensuite pour voir comment elle fonctionne, vous pouvez insérer n'importe quel composant (Cadre 1 dans la page d'accueil) en prenant comme assemblages parents directs à l'étape 6 l'assemblages 9000004 par exemple. Il devrait se passer environ 1 minutes après avoir cliqué sur le bouton de l'étape 8 avant qu'un msgbox apparaisse pour confirmer la saisie. Je vous conseille d'essayer en repartant du fichier d'origine donné sur le forum afin d'être certain que la macro ne va pas être polluée par des "1" dans la colonne "N" de la feuille "Périmètre".

@Qwazerty:

• La feuille vba2 permet de stocker les assemblages liés les un aux autres par niveaux, vous pouvez enlever la suppression des cellules de cette feuille afin de voir visuellement ce stockage. C'est grâce à cela qu'ensuite j'utilise une fonction de recherche pour laquelle les MAJ de modifications se feront pour chaque référence de cette feuille. En clair, à la première colonne, première ligne on a la pièce pour lequel une modif vient d'être effectuée. En dessous de cette ligne, les assemblages parents directs de celle-ci. Encore en dessous, les assemblages parents des assemblages de la pièce et ainsi de suite.
  Effectivement, je débute dans la programmation en vba, d'où un développement légèrement chaotique...

• Concernant votre macro. Je vous remercie, elle fonctionne parfaitement pour une généalogie simple comme tel composant (ou assemblage) à un seul assemblages parent direct qui de même à un seul parent etc. En revanche, dans un cas complexe comme celui exposé en pièce jointe, les MAJ de modifications ne se sont pas. Voyez-vous un moyen de faire ça?

En pièce jointe le fichier avec votre macro, et les composants ajoutés dans la BDD pour faire fonctionner le cas présenté sur l'image.

Je vous remercie une nouvelle fois pour votre aide!!

Bien cordialement,

Eric

20111107_BDD-referencement_FINAL.zip

[Qwazerty]

Salut
En effet, je regarde avec une structure récursive si je peux te faire un truc

[Edit]
Voila un code qui devrait faire la maille

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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Sub testeArboRecu()
Dim Retour As String
Dim Tab_Code As Variant
 
Retour = ArboRecursive("9000018")
Tab_Code = Split(Retour, ";")
 
 
End Sub
 
Function ArboRecursive(Ref As String, Optional FirstUse As Boolean = True) As String
Dim SheetRelation As Worksheet, SheetPerim As Worksheet
Dim ArbreGene As String
Dim CellFind As Range
Dim FirstAddress As String
Dim AutreParent As String
 
    'init
    Set SheetRelation = ThisWorkbook.Sheets("TableRelation")
    Set SheetPerim = ThisWorkbook.Sheets("Périmètre")
 
 
    With SheetRelation.Columns("A")
        'On recherche les parents de Ref
        Set CellFind = .Find(Ref, LookIn:=xlValues)
 
        If Not CellFind Is Nothing Then
            'On memorise la 1er cellule ayant été trouvée
            FirstAddress = CellFind.Address
            Do
                'On ajoute le parent à notre liste avec le séparateur de donnée si besoin
                'Arborecursive = IIf(Arborecursive = "", CellFind.Offset(0, 2).Value, ";" & CellFind.Offset(0, 2).Value)
                'ArbreGene = ArbreGene & ";" & CellFind.Offset(0, 2).Value
                'On recherche ensuite les parents de ce parent, que l'on rajoute à la liste
                AutreParent = ArboRecursive(CellFind.Offset(0, 2).Value, False)
                ArboRecursive = ArboRecursive & IIf((AutreParent <> "") And (ArboRecursive <> ""), ";", "") & AutreParent
                Set CellFind = .Find(Ref, .Cells(CellFind.Row, 1), xlValues)
                'Si pas plus de parent direct ou si retour au 1er parent, on quitte
                If CellFind Is Nothing Then Exit Do
            Loop While CellFind.Address <> FirstAddress
        End If
    End With
 
    'On place notre ref dans l'arbre si différent du produit maitre
    If Ref <> "9000001" Then ArboRecursive = ArboRecursive & IIf((ArboRecursive <> "") And (Ref <> ""), ";", "") & Ref
 
    'On ajoute le maitre à la fin du premier appelle
    If FirstUse Then ArboRecursive = ArboRecursive & IIf((ArboRecursive <> ""), ";", "") & "9000001"
End Function

Par contre l'exécution est un peu longue me semble-t-il, faut voir la taille de tes structures. Il est sans doute possible de réduire le temps de boucle en utilisant un tableau interne ou un dico.
Le dictionary serait intéressant car il permettrait, une fois renseigné, de connaitre rapidement le(s) parent(s) d'un élément en lui passant le nom du fils
++
Qwaz

Salut
Voila ce que ça donne avec un dico, c'est bien plus réactif!

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
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
84
85
86
87
88
89
90
91
92
93
94
95
Sub testeArboDicoRecu()
Dim Retour As String
Dim Tab_Code, TheCode
Dim CellFind As Range
 
Retour = ArboDicoRecursive("9000018")
Tab_Code = Split(Retour, ";")
 
 
'Si l'exection du code qui suit est trop long, on peut le remplacer
'par un autre code utilisant des tableaux de valeur => Execution quasi instantané
 
'On fige la mise à jour écran
Application.ScreenUpdating = False
 
'On met ensuite à jour les dates des composants présants dans la liste
For Each TheCode In Tab_Code
    'On recherche la ref dans la feuille Périmètre
    Set CellFind = SheetPerim.Columns("I").Find(TheRef, LookIn:=xlValues)
 
    If Not CellFind Is Nothing Then
        'On met a jour la date et le User
        CellFind.Offset(0, 3).Value = Format(Date, "dd/mm/yyyy")
        CellFind.Offset(0, 4).Value = Application.UserName
    End If
Next
 
'On réactive la mise à jour écran
Application.ScreenUpdating = True
End Sub
 
Function ArboDicoRecursive(ByVal Ref As String, Optional FirstUse As Boolean = True) As String
Dim SheetRelation As Worksheet
Dim ArbreGene As String
Dim CellFind As Range
Dim FirstAddress As String
Dim AutreParent As String
'Activer la référence Microsoft Scripting Runtime
Static DicoFamille As New Dictionary
Dim Tab_Relation
Dim iTab As Long
Dim RefParent As String
Dim UnParent As Variant
Dim UnCode As String
 
    'init
    Set SheetRelation = ThisWorkbook.Sheets("TableRelation")
 
    'Si le dico ne contient aucune entrée, on le rempli
    If DicoFamille.Count = 0 Then
        'On place les données dans un tableau pour augmenter la vitesse
        With SheetRelation
            Tab_Relation = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 2)).Value
        End With
        'On boucle sur chaque valeur de la 1ere colonne du tableau
        For iTab = 1 To UBound(Tab_Relation)
            UnCode = CStr(Tab_Relation(iTab, 1))
            'On s'assure que la case n'est pas vide et qu'un parent est présent et que l'on est pas sur la structure maitre
            If (UnCode <> "") And (Tab_Relation(iTab, 3) <> "") And (Tab_Relation(iTab, 3) <> "9000001") Then
                'On regarde si le nom de l'élément existe déjà dans le dico
                If DicoFamille.Exists(UnCode) Then
                    'existe déjà, on lui rajoute un parent
                    DicoFamille.Item(UnCode) = DicoFamille.Item(UnCode) & ";" & Tab_Relation(iTab, 3)
                Else
                    'n'existe pas, on le crée
                    DicoFamille.Add UnCode, CStr(Tab_Relation(iTab, 3))
                End If
            End If
        Next
    End If
 
 
 
    'On recherche les parents de Ref, si la Ref exist dans le dico
    If DicoFamille.Exists(Ref) Then
        For Each UnParent In Split(DicoFamille(Ref), ";")
            'On recherche les parents du parent
            AutreParent = ArboDicoRecursive(UnParent, False)
            ArboDicoRecursive = ArboDicoRecursive & IIf((AutreParent <> "") And (ArboDicoRecursive <> ""), ";", "") & AutreParent
        Next
    End If
 
    'On place notre ref dans l'arbre
    ArboDicoRecursive = ArboDicoRecursive & IIf((ArboDicoRecursive <> "") And (Ref <> ""), ";", "") & Ref
 
    'On ajoute le maitre à la fin du premier appelle
    If FirstUse Then
        ArboDicoRecursive = ArboDicoRecursive & IIf((ArboDicoRecursive <> ""), ";", "") & "9000001"
        'On libert le dico
        DicoFamille.RemoveAll
        Set DicoFamille = Nothing
    End If
 
 
End Function

Je n'ai pas testé la partie mise à jour des date/User.
Si tu vois que cette partie prend trop de temps essai d'utiliser des tableaux de valeur et reviens vers nous si problème.

++
Qwaz

[RicoExo]

Super merci!

Mais j'ai une erreur "Espace pile insuffisant"... Je me décourage, je crois que je vais laisser tomber cette fonction ou alors je vais faire accepter à notre BE de prendre leur temps pour remplir la BDD!

Merci pour tout Qwazerty.

Eric

[Qwazerty]

Salut
Si tu ne dis pas sur quelle ligne l'erreur se produit, il va être difficile de t'aider :p
++
Qwaz