Discussion :

[syl150]

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 :

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
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)Doc tranport2.xlsm

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

Merci

[bpascal123]

Il y a en effet quelques améliorations possibles

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
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

[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 :

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

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

Merci

[AlainTech]

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

Bonjour,

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

[bpascal123]

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 :

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

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 :

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

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.

[syl150]

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