Discussion :

[jpvba]

Bonjour a vous cher(e)s ami(e)s du forum,


J'ai un procédure fonctionnel mais très lente auquel je voudrais remplacer par quelques chose de plus rapide, si cela est possible.



Voici donc la procédure en question

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
Sub copie_noproduit_ancienne_longue_et_mandat()
 
Dim x As Long
Dim cell As Variant
Dim LettreVoulue As String
LettreVoulue = TrouveLettreColonne([no_item_travail])
 
On Error GoTo errohandler:
 
Application.ScreenUpdating = False
 
Sheets("Travail").Select
 
For Each cell In Worksheets("Travail").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInColumn(LettreVoulue))
 
        x = x + 1
 
'nettoyer les no d'item
 
    Sheets("Travail").Cells(x + 1, [no_item_travail].Column) = _
    StripAccent(UCase(CleanTrim(Sheets("Travail").Cells(x + 1, [no_item_travail].Column).value)))
 
 
'recherche et copie de l'ancienne provinciale longue
 
    Sheets("Travail").Cells(x + 1, [ancienne_prov_longue].Column) = Application.VLookup(Sheets("Travail").Cells _
    (x + 1, [no_item_travail].Column), _
    Worksheets("catalogue").Range("A1").CurrentRegion, 3, False)
 
 
'recherche et copie du no produit
 
    Sheets("Travail").Cells(x + 1, [no_produit_travail].Column) = Application.VLookup(Sheets("Travail").Cells _
    (x + 1, [no_item_travail].Column), _
    Worksheets("catalogue").Range("A1").CurrentRegion, 2, False)
 
 
'recherche et copie mandat
 
    Sheets("Travail").Cells(x + 1, [mandat_lac].Column) = rmult(Sheets("Travail").Cells _
    (x + 1, [no_item_travail].Column), _
    Worksheets("mandat").Range("A1").CurrentRegion, 2)
 
 
    Next cell
 
Application.ScreenUpdating = True
 
Exit Sub
 
errohandler:
 
Application.ScreenUpdating = True
MsgBox "erreur sur la ligne " & x + 1, vbCritical
 
End Sub

DOnt celle-ci contient les procédures et/ou fontions suivantes :

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
 
Public Function TrouveLettreColonne(ByVal ColonneCherche As Range) As String
 
TrouveLettreColonne = Split(Columns(ColonneCherche.Column).Address(ColumnAbsolute:=False), ":")(1)
 
End Function
 
Public Function LastLignUsedInColumn(NomColumn As String)
 
LastLignUsedInColumn = Range(NomColumn & Rows.Count).End(xlUp).Row
 
End Function
 
Function CleanTrim(ByVal S As String, Optional ConvertNonBreakingSpace As Boolean = True) As String
 
    Dim x As Long, CodesToClean As Variant
 
    CodesToClean = Array(0, 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, 127, 129, 141, 143, 144, 157)
 
    If ConvertNonBreakingSpace Then S = Replace(S, Chr(160), " ")
 
    For x = LBound(CodesToClean) To UBound(CodesToClean)
 
    If InStr(S, Chr(CodesToClean(x))) Then S = Replace(S, Chr(CodesToClean(x)), "")
 
    Next
 
    CleanTrim = WorksheetFunction.Trim(S)
 
End Function
 
Function rmult(valeurachercher As Variant, plageachercher As Range, numcolonne As Long) As Variant
    Dim u As Variant
    Dim nb As Long
    Dim boucle As Long
 
    For boucle = 1 To plageachercher.Rows.Count
 
        If plageachercher(boucle, 1) = valeurachercher Then
            u = u & plageachercher(boucle, numcolonne) & Chr(10)
            nb = nb + 1
        End If
 
    Next boucle
 
    If Right$(u, 1) = Chr(10) Then u = Left$(u, Len(u) - 1)
 
    rmult = u
 
End Function

Cette procédure permet de populer un fichier de travail. Elle fait 2 vlookup afin de populer de l'information pertinente ainsi que la fonction rmult qui est comme un vlookup mais renvoi toute les données possibles contrairement a vlookup qui renvoi seulement le premier trouvé. C'Est à mon avis cette dernière fonction qui ralenti un peu mon processus.


Donc j'ai deux questions sois pouvont nous effectuer cette popuilation de mon fichier en lot ou block au lieu de passé ligne par ligne ??? Si cette dernière n'Est pas possible avez vous une solution afin de rendre plus rapide la fonction rmult ???




merci d'avance pour le temps consacrer a m'aider, c'est plus qu'apprécié !!!

amicalement JP

[marot_r]

Bonjour.

Il est très possible que LastLignUsedInColumn(LettreVoulue) soit exécuté pour chacune des lignes donc si il ne change pas je te suggère :

Code :

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

1
2
3
dim derniereLigne as long: dernierLigne=LastLignUsedInColumn(LettreVoulue)
...
For Each cell In Worksheets("Travail").Range(LettreVoulue & 2, LettreVoulue & lastLine)

Comme toutes tes données copiées semblent sur la même ligne dans la feuille source, tu pourrais utiliser WorksheetFunction.Match(TaValeur, TaColonneDeRecherhe, 0) pour récupérer le numéro de la ligne dans la source.
Après tu peux simplement copier les données directement de cette ligne plutôt que de faire une recherche à chaque fois.

Si tu n'as pas de sélection par filtre dans ta feuille source, tu pourrais aussi utiliser TaFeuilleSource.TaColonneDeDonnees.Find() qui te retourne la cellule contenant la donnée. Aprèes tu n'as plus qu'à prendre l'offset de cette cellule pour récupérer les données adjacentes.

Enfin tu pourrais peut-être neutraliser les calculs jusqu'à la fin de la procédure.

Au début tu mets Application.Calculation=xlCalculationManual.
et à la fin tu mets Application.Calculation=xlCalculationAutomatic.

Comme cela au lieu de faire tes calculs à chaque modification de la valeur d'une cellule, tu ne les fait qu'une seule fois après toutes les modifs.

A+

[jpvba]

Un gros merci marot_R


c'est vraiment apprécié !!!


J'ai testé en mettant LastLignUsedInColumn(LettreVoulue) comme variable et résultat approximatif meme legerement suppérieur d'une seconde à la procédure de départ

MOn calcul était déjà en mode manuel, donc en mettant également Application.Calculation=xlCalculationManual n'a pas changer dans ma situation mais cela aurais pu etre effectivement un ralentissement pénible


Il me reste les 2 autres possibilités que vous m'avez identifiés a testé, cependant a titre indicatif ma donnée cherché est dans la feuille Travail colonne C. Mes données auquel je trouve l'information sont dans la colonne C et E, donc non contigüe.

Si je comprends bien, je ne peut utiliser l'option de la copie de ligne complete étant donné ce fais ?


L'option TaFeuilleSource.TaColonneDeDonnees.Find() semble celle qui selon moi pourrais me gagner du temps.


Je vais donc la tester et vous revenir si j'ai un gain en vitesse.


merci encore une fois pour votre coup de pouce !!!!!

[RyuAutodidacte]

Bonjour ,

Tu peux toujours utiliser une feuille tampon avec un filtre élaboré qui te permettra d'afficher toutes les lignes trouvées et seulement les colonnes C et E
on l'avait déjà vu

=> les explications si besoin : Les filtres avancés ou élaborés dans Excel

et là c'est très rapide

[jpvba]

Super Ryu,


Je vais essayer les filtres élaborés après avoir terminé la solution de marot_r que je n'ai pas encore eu le temps de tester.



Si le filtre élaboré pourrais également remplacer la fonction rmult, là j'aurais le top du top en terme de vitesse


Je vous reviens donc après mes tests !!!


merci encore les amis

[jpvba]

Bonjour a vous,


J'ai finalement décidé d'essayé en premier la solution de Ryu et je n'ai malheureusement aucun gain de vitesse . , j'ai environ le meme résultat

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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
Sub test_copie_Filtre()
 
Dim x As Long
Dim cell As Variant
Dim LettreVoulue As String
LettreVoulue = TrouveLettreColonne([no_item_travail])
 
 
Dim start As Single
Dim finish As Single
 
 
start = Timer
 
 
 
On Error GoTo errohandler:
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
If sheetExists("filtre") Then Sheets("filtre").Delete
 
 
'_______________________________________________________
 
Sheets.Add.Name = "filtre"
 
Sheets("filtre").Range("a1") = Sheets("catalogue").Range("a1")
Sheets("Travail").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet_Column("Travail", LettreVoulue)).Copy Sheets("filtre").Range("a2")
 
 
Sheets("filtre").Range("d1") = Sheets("catalogue").Range("b1")
Sheets("filtre").Range("e1") = Sheets("catalogue").Range("c1")
 
 
 
'on nomme la plage filtration afin de facilité le code
 
    Sheets("filtre").Range("a2").CurrentRegion.Name = "item_filtre"
 
'on nomme la plage de destination afin de facilité le code
 
    Sheets("filtre").Range("d2").CurrentRegion.Name = "destination"
 
'on nomme la plage de départ afin de facilité le code
 
    Sheets("catalogue").Range("d2").CurrentRegion.Name = "depart"
 
 
Sheets("catalogue").[depart].AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=[item_filtre], CopyToRange:=[Destination], _
        Unique:=True
 
 
Sheets("filtre").Range("d2:d" & LastLignUsedInSheet("filtre")).Copy _
Sheets("Travail").Range(TrouveLettreColonne([no_produit_travail]) & 2)
 
 
Sheets("filtre").Range("e2:e" & LastLignUsedInSheet("filtre")).Copy _
Sheets("Travail").Range(TrouveLettreColonne([ancienne_prov_longue]) & 2)
 
Sheets("filtre").Delete
 
'_______________________________________________________
 
 
Sheets("Travail").Select
 
For Each cell In Worksheets("Travail").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInColumn(LettreVoulue))
 
        x = x + 1
 
'nettoyer les no d'item
 
    Sheets("Travail").Cells(x + 1, [no_item_travail].Column) = _
    StripAccent(UCase(CleanTrim(Sheets("Travail").Cells(x + 1, [no_item_travail].Column).value)))
 
 
 
 
'recherche et copie mandat
 
    Sheets("Travail").Cells(x + 1, [mandat_lac].Column) = rmult(Sheets("Travail").Cells _
    (x + 1, [no_item_travail].Column), _
    Worksheets("mandat").Range("A1").CurrentRegion, 2)
 
 
    Next cell
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
finish = Timer
MsgBox "durée du traitement: " & finish - start & " secondes"
 
 
Exit Sub
 
errohandler:
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "erreur sur la ligne " & x + 1, vbCritical
 
End Sub

Il me reste la dernière option de marot_r, sinon c'est mon code de départ ...