Optimisation d'une macro

Version imprimable

1 pièce(s) jointe(s)

Bonjour a tous

Je viens de créer une macro par "tâtonnement" qui me permet pour chaque ligne d'un tableau de saisie de commande (commande CETA) d'extraire uniquement les produits présents. Ainsi j'obtiens un "bon de livraison" en aperçu avant impression pour chaque client avec les seuls produits commandé.
Cependant cette macro est très lente et malgré les discussions sur le sujet dans ce forum je n'arrive pas à l’accélérer. J'ai bien essayé d'enlever les "select" mais les "SpecialCells(xlCellTypeVisible)" me pose problème.

Voici la macro:
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 Sub essai() Application.ScreenUpdating = False For i = 3 To Sheets("Commande CETA").[A65000].End(xlUp).Row Range("compteur") = i - 2 Sheets("Feuil2").Range("C6:D150").ClearContents Sheets("Commande CETA").Select ActiveSheet.Calculate If Cells(i, "B") <> 0 Then Range("C" & i, "DP" & i).SpecialCells(xlCellTypeVisible).Select Selection.Copy Worksheets("Feuil2").Select Range("D6").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Sheets("Commande CETA").Select Range("Produit").SpecialCells(xlCellTypeVisible).Select Selection.Copy Worksheets("Feuil2").Select Range("C6").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Range("C5").AutoFilter Field:=2, Criteria1:="<>" Sheets("Feuil2").PrintPreview End If Next Application.ScreenUpdating = True End Sub
Je joins également le fichier (le bouton noir de la feuill2 lance la macro)Pièce jointe 200460

Pourriez vous m'indiquer la démarche a suivre.

Merci

améliorations 1

Il y a en effet quelques améliorations possibles

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
Sub essai()
 
'Application.ScreenUpdating = False
 
with application
.screenupdating= false
.displayalerts=false
.calculation=xlmanual 'commente si tu as besoin des calculs en temps réel
end with
 
dim feuil_CETA as worksheet
dim feuil_2 as worksheet
dim r as range
dim der_lig as long
 
with thisworkbook
set feuil_CETA = .worksheets("Commande CETA")
set feuil_2 = .worksheets("Feuil2")
end with
 
with feuil_CETA
 
der_lig = .cells(.rows.count, 1).end(xlup).row
 
For i = 3 To der_lig
.Range("compteur") = i - 2 'feuille CETA?
 
'feuil_2.activate en cas de bug
feuil_2.Range("C6150").ClearContents
 
.activate 'feuil commande CETA, évite Select qui est couteux
.calculate 'très couteux si la feuille a beaucoup de formules, c'est mieux de lancer calculate en fin de script
 
If .Cells(i, "B") <> 0 Then
 
set r = .range("C" &i, "DP" &i)
with r.SpecialCells(xlCellTypeVisible)
.copy feuil_2.range("D6")
.copy feuil_2.range("C6")
end with
 
.Range("C5").AutoFilter Field:=2, Criteria1:="<>"
 
feuil_2.activate 'en cas de bug
feuil_2.PrintPreview 'JE NE SUIS PAS SURE DE COMPRENDRE CETTE INSTRUCTION (elle prévisualise la feuille à l'intérieur de la boucle???) Ne faudrait-il pas la sortir de la boucle FOR?
End If
Next i
end with 'feuil_CETA
 
'Application.ScreenUpdating = True
 
with application
.screenupdating= true
.displayalerts=true
.calculation=xlautomatic 'commente si tu as besoin des calculs en temps réel
end with
 
End Sub

Pascal

10/02/2016, 16h06
syl150

Merci pour cette réponse.

En fait le but de la macro est au final d'imprimer les "bon de transport" un par un mais pour l'instant j'ai mis l'instruction feuil_2.PrintPreview pour ne pas imprimer à chaque test. Je remplacerai une fois la macro terminée par Printout.

Cependant je viens de tester le code modifié et la boucle ne se fait pas. J'ai toujours le même numéro de client avec aucun produit d'afficher.
Par ailleurs dans ce code je ne vois pas comment la transposition d'horizontale en verticale a lieue?

PS :dans mon code un smiley s'était glissé, il faillait lire

Code:

Sheets("Feuil2").Range("C6:D150").ClearContents

Merci
10/02/2016, 20h56
AlainTech

Citation:

Envoyé par syl150

PS :dans mon code un smiley s'était glissé, il faillait lire Sheets("Feuil2").Range("C6:D150").ClearContents

Bonjour,

Quand on utilise les balises [code], on n'a pas ce souci.

oops, je n'ai pas vu l'argument .transpose de la méthode pastespecial.

Dans ce cas, il faut modifier le script que j'ai posté à la ligne 36
Code:

1 2 3 4 5 set r = .range("C" &i, "DP" &i) with r.SpecialCells(xlCellTypeVisible) .copy feuil_2.range("D6") .copy feuil_2.range("C6") end with
Les méthodes copy vont se faire sur 2 lignes, je ne sais pas si ça fonctionne sur une ligne, mais de mémoire ça doit ressembler à quelque chose comme ça
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 set r = .range("C" &i, "DP" &i) with r.SpecialCells(xlCellTypeVisible) .select .selection.copy feuil_2.range("D6").Select selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True feuil_2.range("C6").Select selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True end with
C'est un script comme ça sans tester sous excel. Il y a très certainement des ajustements.

12/02/2016, 11h44
syl150

Merci pour vos réponses, j'essaye de me débrouiller avec ça et je vous retiens au courant.

Bonjour

Merci pour votre aide, j'ai réussi à obtenir une macro fonctionnelle.

J'ai encore une petite question d'optimisation. Est-il possible d'accélérer la macro suivante dans laquelle il y a la fonction Vlookup et la fonction Concatener.

Code:

1
2
3
4
5
6
7
8
 
For ii = 10 To derlig3
With feuil_doc
    .Range("C" & ii).Value = (WorksheetFunction.VLookup(.Range("A" & ii).Value, Sheets("Produits").Range("Produits"), 3, False)) * Range("B" & ii)
    .Range("D" & ii).Value = (WorksheetFunction.VLookup(.Range("A" & ii).Value, Sheets("Produits").Range("Produits"), 11, False)) * Range("C" & ii)
    .Range("E" & ii).Value = (WorksheetFunction.VLookup(.Range("A" & ii).Value, Sheets("Produits").Range("Produits"), 2, False)) & " x " & (Range("B" & ii) / (WorksheetFunction.VLookup(.Range("A" & ii).Value, Sheets("Produits").Range("Produits"), 2, False)))
    .Range("F" & ii).Value = (WorksheetFunction.VLookup(.Range("A" & ii).Value, Sheets("Produits").Range("Produits"), 12, False)) & " - " & (WorksheetFunction.VLookup(.Range("A" & ii).Value, Sheets("Produits").Range("Produits"), 5, False)) & " - " & (WorksheetFunction.VLookup(.Range("A" & ii).Value, Sheets("Produits").Range("Produits"), 6, False)) & " - " & (WorksheetFunction.VLookup(.Range("A" & ii).Value, Sheets("Produits").Range("Produits"), 7, False))
End With

Merci

Bonjour,

Tu peux référencer la plage de données "Produits" au début du script avec:
Code:

1 2 dim rg_Produits as range set rg_Produits = thisworkbook.worksheets("Produits").range("Produits")
et de mettre la plage dans le script que tu veux optimiser
Code:

1 2 3 4 5 6 With feuil_doc .Range("C" & ii).Value = (WorksheetFunction.VLookup(.Range("A" & ii).Value, rg_Produits, 3, False)) * Range("B" & ii) .Range("D" & ii).Value = (WorksheetFunction.VLookup(.Range("A" & ii).Value, rg_Produits, 11, False)) * Range("C" & ii) .Range("E" & ii).Value = (WorksheetFunction.VLookup(.Range("A" & ii).Value, rg_Produits, 2, False)) & " x " & (Range("B" & ii) / (WorksheetFunction.VLookup(.Range("A" & ii).Value, rg_Produits, 2, False))) .Range("F" & ii).Value = (WorksheetFunction.VLookup(.Range("A" & ii).Value, rg_Produits, 12, False)) & " - " & (WorksheetFunction.VLookup(.Range("A" & ii).Value, rg_Produits, 5, False)) & " - " & (WorksheetFunction.VLookup(.Range("A" & ii).Value, rg_Produits, 6, False)) & " - " & (WorksheetFunction.VLookup(.Range("A" & ii).Value, rg_Produits, 7, False)) End With
et en fin de code

Code:

set rg_Produits = nothing

mais ce n'est pas indispensable

Autre optimisation (accessoire):

Le feuil_doc.Range("C" & ii).Value ainsi que tous les autres peuvent être remplacés par une référence unique sur une plage de données, ex.:

Code:

set rg_fdoc = feuil_doc.range("A1")

et ensuite dans le script ci-dessus, tu appliques la méthode offset, pour la première ligne dans la boucle, ça donnerait:

Code:

rg_fdoc.offset(ii,3) = (WorksheetFunction.VLookup(.rg_fdoc.offset(ii,) , rg_Produits, 3, False)) * rg_fdoc.offset(ii,1)

C'est ce que je peux voir comme principales optimisations, il doit y en avoir d'autres s'ils suscitent la curiosité des experts qui te lisent.

Cordialement

Pascal

heu

bonsoir tous les 2
ôtez moi le doute

r a bien 2 cellules et non pas la ligne entière de C a DP
Code:

1 2 3 4 5 set r = .range("C" & i ,"DP" & i)'comme ca la plage r contiens que 2 cellules with r.SpecialCells(xlCellTypeVisible) .copy feuil_2.range("D6") .copy feuil_2.range("C6") end with
SI C EST PAS LE CAS VOUS AVEZ TOUT FAUX
SE SERAIT PLUTOT
Code:

1 2 3 set r = .range("C" & i ":DP" & i)' comme ca r contiens toutes les cellules de C à DP
ce qui justifierait le xltype visible dans la sélection

17/02/2016, 22h26
syl150

r a bien la ligne entière.
La copie a bien lieue de C à DP avec l'expression ("C" & i ,"DP" & i) alors que ("C" & i ":DP" & i) m'indique "erreur de syntaxe".

Merci
18/02/2016, 01h33
patricktoulon

re

autant pour moi
la syntaxe c'est ("C" & i & ":DP" & i).
mais si tu me dis que ta version avec la virgule prends toute la ligne ton excel et ton VBA SONT EXOTIQUES:calim2:

PAR CE QUE CHEZ MOI C EST TA VERSION QUI BUGUE DU MOINS ELLE ME DONNE Cx ET DPx (2 CELLULES )

EN GENERAL ON SE SERT DE LA FORMULE AVEC LA VIRGULE POUR LES PLAGES NON CONTIGUES

exemple1

set r= .range("A1","C3","H15" )--> 3 cellule

exemple2
set r= .range("A1:H15")---> toutes les cellules de a1 à h15

ma foi c'est bizare