Discussion :

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

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

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

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

Code :

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

    Sheets("BD").Cells.ClearContents

Code :

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

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 :

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

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

etc etc .....

Sans oublier

Code :

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

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

[mercatog]

Une proposition sur ton code, à adapter éventuellement

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

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

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

- par la ligne:

Code :

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

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