[XL-2007] Boucles For Each Next: problème de défilement des feuilles avec lenteur d'exécution [Résolu]

[camelia.w]

Bonjour,
J'ai une macro avec boucle for each next que je viens de confectionner après beaucoup d'efforts (je suis débutante en VBA) et qui fonctionne bien.
Le seul problème est le suivant: lorsque j'exécute cette macro, les feuilles commencent à défiler une à une, ralentissant l'exécution des commandes et l'affichage des résultats. Je suis consciente que le code utilisé doit certainement être trop "lourd".
Le classeur est constitué de plusieurs feuilles, dont une feuille de synthèse "BD". Plusieurs feuilles sont nommées "service*": service administratif, achat, vente,etc. Les données de ces feuilles devaient être regroupées dans la feuille BD sous forme de tableau.
Ma question est la suivante: j'aimerais beaucoup que vous m'aidiez s'il vous plait à trouver une forme plus légère et plus rapide.
Je vous remercie d'avance pour votre temps et vos efforts

Le code est le suivant:

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
Sub MacroFINALEssai()
'
Dim numLigneVideUn As Integer
Dim ws As Worksheet
 
    Sheets("BD").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Nom Matériel"
    Range("B1").Select
    Sheets("Service Administration").Select
    Range("A600:A612").Select
    Selection.Copy
    Sheets("BD").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
 
For Each ws In ThisWorkbook.Worksheets
    If ws.Name Like "Service*" Then
    Sheets(ws.Name).Select
       Range("B1", Range("B1").End(xlToRight)).Select
       Selection.Copy
     Sheets("BD").Activate
    'on trouve la dernière ligne vide de la colonne A et on enregistre le numéro de la ligne dans la variable numLigneVide
    numLigneVide = Range("A65536").End(xlUp).Row + 1
    ActiveSheet.Cells(numLigneVide, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    Sheets(ws.Name).Select
       Range("B600:B612", Range("B600:B612").End(xlToRight)).Select
       Selection.Copy
     Sheets("BD").Activate
    'on trouve la dernière ligne vide de la colonne B et on enregistre le numéro de la ligne dans la variable numLigneVide
    numLigneVide = Range("B65536").End(xlUp).Row + 1
    ActiveSheet.Cells(numLigneVide, 2).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    Sheets(ws.Name).Select
    Range("B3").Select
 
 
End If
Next
Sheets("Sommaire").Select
End Sub

[kiki29]

Salut, déjà commencer par supprimer tous les select

Code :

1
2
3
    Sheets("BD").Select
    Cells.Select
    Selection.ClearContents

Code :

    Sheets("BD").Cells.ClearContents

Code :

1
2
3
4
5
    Range("A600:A612").Select
    Selection.Copy
    Sheets("BD").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False

Code :

    Range("A600:A612").Copy Sheets("BD").Range("A1") ' ????

etc etc .....

Sans oublier

Code :

1
2
3
4
 
    Application.ScreenUpdating = False
    ' .....
    Application.ScreenUpdating = True

[mercatog]

Une proposition sur ton code, à adapter éventuellement

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
Sub MacroFINALEssai()
Dim Ws As Worksheet
 
Application.ScreenUpdating = False
With Worksheets("BD")
    .UsedRange.Clear
    .Range("A1") = "Nom Matériel"
    .Range("B1:B13").Value = Worksheets("Service Administration").Range("A600:A612").Value
 
    For Each Ws In ThisWorkbook.Worksheets
        If Ws.Name Like "Service*" Then
            CopieTransp .Name, 1, Ws.Range("B1", Ws.Range("B1").End(xlToRight))
            CopieTransp .Name, 2, Ws.Range("B600:B612", Ws.Range("B600:B612").End(xlToRight))
        End If
    Next Ws
End With
End Sub
 
 
Private Sub CopieTransp(ByVal FeuilDest As String, ByVal ColDest As Byte, RngSce As Range)
Dim NewLig As Long
 
With ThisWorkbook.Worksheets(FeuilDest)
    NewLig = .Cells(.Rows.Count, ColDest).End(xlUp).Row + 1
    RngSce.Copy
    .Cells(NewLig, ColDest).PasteSpecial Paste:=xlValues, Transpose:=True
    Application.CutCopyMode = False
End With
End Sub

[camelia.w]

Merci les amis pour votre réponse et votre aide précieuse.
Grâce à vous le problème est résolu!
Mercatog, merci pour la solution, je n'ai eu pour l'adapter qu'à remplacer:
- la ligne:

Code :

Range("B1:B13").Value = Worksheets("Service Administration").Range("A600:A612").Value

- par la ligne:

Code :

.Range("B1:N1").Value =Application.Transpose(Worksheets("Service Administration").Range("A600:A612").Value)

Car il me fallait un collage transposé.
Je vous souhaite Joyeux Noël et de bonnes fêtes de fin d'année.
Et encore une fois merci!