XL 2010 Exécution macro très lente

[alias_2003]

Bonjour à tous,
J'ai un soucis avec une macro et j'aurais besoin de vos conseils...
J'ai écrit une macro qui me permet de :
1. filtrer les données non vides de la colonne Y du tableau1 présent dans la feuille 1 de mon classeur
2. une fois filtrée, les cellules de cette feuille1 sont copiées vers une feuille 2 du même classeur. Je peux alors travailler la mise en page et notamment supprimer les colonnes C à Y.
3. la feuille 2 est alors affichée en print preview.

Voici le code :

Sub Imprimer()
Dim DernLigne As Long
Dim i As Integer

    On Error Resume Next
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayGridlines = False
    Set Ws1 = Sheets("Feuille 1")
    Set Ws2 = Sheets("Feuille 2")
    Ws1.Visible = xlSheetVisible
    W2Visible = xlSheetVisible
    Ws2.Cells.ClearContents
    Ws1.Activate

    Ws1.ListObjects("Tableau1").Range.AutoFilter Field:=25, Criteria1:="<>"

    Ws2.Select
    Ws2.Cells.Delete
    Ws1.Cells.Copy WsFDS.Range("A1")

    With Ws2
        DernLigne = .Range("A1048576").End(xlUp).Row
        .Columns("C:Y").Delete
        .ListObjects(1).Name = "Liste"
        .ListObjects("Feuille 2").TableStyle = "TableStyleMedium1"

        .Range("A1").Value = .Range("A1").Value & " " & .Range("B1").Value
        .Range("A2").Value = .Range("A2").Value & " " & .Range("B2").Value
        .Range("A3").Value = .Range("A3").Value & " " & .Range("B3").Value
        .Range("B1:B3").ClearContents
        .Range("A1:A3").HorizontalAlignment = xlLeft
        .Range("A" & DernLigne + 3).Value = "BLABLA."
        .Range("A" & DernLigne + 4).Value = "NOM:"
        .Range("A" & DernLigne + 5).Value = "PRENOM:"
        .Columns("A:B").AutoFit

        With .PageSetup
            .PrintArea = ActiveSheet.Range("A1:B" & DernLigne + 5).Address
            .TopMargin = Application.InchesToPoints(1.1)
            .Orientation = xlLandscape
            .Draft = False
            .PaperSize = xlPaperA4
            .PrintTitleRows = "$1:$5"
        End With
     
        Userform1.Hide
        .PrintPreview
        .Visible = xlSheetVeryHidden
        Userform1.Show 0
    End With
    Ws2.Cells.Delete
    Ws1ListObjects("Tableau1").Range.AutoFilter Field:=25
    Ws2.Cells.delete
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Je trouve que l'exécution de cette macro est trop lente (entre 6 et 12s...). Pourriez-vous m'aider à l'optimiser ?
Merci beaucoup,
Bon dimanche

 

[mdo100]

Bonjour alias_2003, toutes et tous,

Écrire ce bout de code en dessous de "Dim i As Integer"

Application.ScreenUpdating = False

Ça devait aller plus vite, si je me trompe pas.

Cordialement.

 

[alias_2003]

Bonjour mdo100,
Merci beaucoup de ta réponse ! C'est aussi ce que je pensais mais le problème est que cette instruction est déjà dans mon code...
Merci encore !
Bonne journée,

 

[Staple1600]

Bonjour à tous

alias_2003

Pourriez-vous m'aider à l'optimiser ?

Oui.
Mais en retour vous pourriez nous aider à optimiser nos réponses en prenant soin de joindre un fichier exemple en cliquant sur le bouton Téléverser

 

[Theze]

Bonjour,

Déjà, je sais que tu n'as pas mis "Option Explicit" en tête de module car tu crée les variables à la volée pour preuve cette ligne de code :

W2Visible = xlSheetVisible

alors que je suppose qu'elle devrati être :

Ws2.Visible = xlSheetVisible

et il en va de même pour cette ligne de code :

Ws1ListObjects("Tableau1").Range.AutoFilter Field:=25

car je suppose que c'est ceci qui devrait être :

Ws1.ListObjects("Tableau1").Range.AutoFilter Field:=25

Pareil pour ici :

Ws1.Cells.Copy WsFDS.Range("A1")

c'est quoi cette variable Feuille "WsFDS" qui n'est ensuite utilisée nulle part ?
donc ceci a pour effet de créer des variables qui ne serviront à rien dans la suite du code. Je sais que ce n'est pas ça qui ralenti le code mais je te conseille fortement d'obliger la déclaration des variables de façon explicite, ce que demande l'instruction "Option Explicit", ça tévitera de t'arracher les cheveux dans bien des cas. Tu peux faire en sorte que ce soit automatique en cochant la case "Déclaration des variables obligatoire" dans "Outils"-->"Options..."-->Onglet "Editeur"
D'ailleurs, je me demande comment ton code peut fonctionner ?
Quand on utilise "Application.ScreenUpdating = False" dans le code, il ne sert à rien d'utiliser les "Select", "Activate" et tout autres choses du même acabit qui eux ralentissent le code car, comme tu parentes tous tes Range (ce qui est une très bonne pratique) il ne sert absolument à rien d'activer et sélectionner les objets.
Dans "With Ws2" tu utilises ".Columns("C:Y").Delete" mais tu viens juste avant de supprimer toutes les cellules avec "Ws2.Cells.Delete" donc redondance !
Pour ce qui est de la lenteur, je pense que c'est le filtrage et la mise en page.
Pose un ou des MsgBox juste avant et après ces instructions, ça te donnera une indication de vitesse !

 

[Staple1600]

Re à tous, Bonjour Theze

J'allais faire les mêmes remarques quant aux erreurs de syntaxe (les points manquants)
En attendant un hypothétique fichier exemple, j'ai testé cette simple macro qui suffit pour copier le résultat d'un filtre d'un Tableau de la feuille1 vers la feuille 2.

Sub a()
Dim LObj As ListObject, Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Sheets(1): Set Ws2 = Sheets(2)
Ws2.Cells.Clear
Set LObj = Ws1.ListObjects("Tableau1")
    LObj.Range.AutoFilter Field:=25, Criteria1:="<>"
    LObj.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    Ws2.Paste
End Sub

Pas de ralentissement notable.

 

[alias_2003]

Bonjour Staple1600, Theze
Voici !!
Merci beaucoup !

Edit : en effet, il y avait des erreurs dans le code...

 

[Staple1600]

Re

alias_2003
Tu as vu le code VBA de mon précédent message ?

 

[alias_2003]

Re-,
Pas encore, tu vas plus vite que moi !
Merci beaucoup !

 

[alias_2003]

Re-,
J'ai testé ton code Staple1600 et je te confirme que c'est beaucoup plus rapide !
merci !

 

[Staple1600]

Re

J'ai trois questions:
1) Qu'est censé faire cette partie du code ???

.Range("A1").Value = .Range("A1").Value & " " & .Range("B1").Value
        .Range("A2").Value = .Range("A2").Value & " " & .Range("B2").Value
        .Range("A3").Value = .Range("A3").Value & " " & .Range("B3").Value
        .Range("B1:B3").ClearContents
        .Range("A1:A3").HorizontalAlignment = xlLeft
        .Range("A" & DernLigne + 3).Value = "BLABLA."
        .Range("A" & DernLigne + 4).Value = "NOM:"
        .Range("A" & DernLigne + 5).Value = "PRENOM:"

2) Dans quelle cellule doit se faire la recopie sur la feuille 2 ?
A1 ?

3) Faut-il recopier le tableau filtré avec ou sans les entêtes?

 

[alias_2003]

Re,
Alors , c'est juste de la mise en forme avant impression !

.Range("A1").Value = .Range("A1").Value & " " & .Range("B1").Value
        .Range("A2").Value = .Range("A2").Value & " " & .Range("B2").Value
        .Range("A3").Value = .Range("A3").Value & " " & .Range("B3").Value
        .Range("B1:B3").ClearContents

J'aurais aimé regrouper le contenu des cellules A1 et B1 en A1, A2et B2 en A2 et A3 et B3 en A3.

        .Range("A" & DernLigne + 3).Value = "BLABLA."
        .Range("A" & DernLigne + 4).Value = "NOM:"
        .Range("A" & DernLigne + 5).Value = "PRENOM:"

Là, le but est d'ajouter d'autres infos (le nom/prénom n'est pas le même qu'en A1, A2 !

 

[Staple1600]

Re

???
Il n'y a ni nom ni prénom dans ton fichier exemple
(Un fichier exemple plus proche de la réalisé mais avec des données fictives ne serait pas de trop!)

PS: Tu n'as répondu qu'à une question sur trois!

Sinon, j'ai récrit mon code avec une autre logique
Cela donne quoi chez toi?

Sub b()
Dim LObj1 As ListObject, Ws1 As Worksheet, Ws2 As Worksheet, Suppr As Range
Set Ws1 = Sheets(1): Set Ws2 = Sheets(2)
Ws2.Cells.Clear
Set LObj1 = Ws1.ListObjects("Tableau1")
Ws1.Range("Tableau1[#All]").Copy Ws2.[A1]
With Ws2.ListObjects(1)
    .Name = "List": .TableStyle = "TableStyleMedium1"
    .Range.AutoFilter Field:=25, Criteria1:="="
    With .DataBodyRange
        Set Suppr = .SpecialCells(xlCellTypeVisible)
        .AutoFilter
    End With
End With
Suppr.Delete
Ws2.Columns("C:Y").Delete
End Sub

 

[alias_2003]

Re-,
Merci pour le code, je le teste et je reviens vers toi !

Il n'y a ni nom ni prénom dans ton fichier exemple

        .Range("A" & DernLigne + 3).Value = "BLABLA."
        .Range("A" & DernLigne + 4).Value = "NOM:"
        .Range("A" & DernLigne + 5).Value = "PRENOM:"

Là, j'ajoute juste du texte, la personne devra écrire son nom et signer !

J'avais pas vu tes questions 2 et 3 !

2) Dans quelle cellule doit se faire la recopie sur la feuille 2 ?
A1 ?

En A6 , c'est à dire comme sur la feuille 1 !

3) Faut-il recopier le tableau filtré avec ou sans les entêtes?

Si possible, ce serait parfait!
MERCI !!

 

[Staple1600]

Re

Ta réponse à la 3ième question ne répond pas à la question posée

Quelques ajouts
Qu'en est-il au niveau rapidité d’exécution ?

Sub c()
Dim Ws1 As Worksheet, Ws2 As Worksheet, Suppr As Range
Set Ws1 = Sheets(1): Set Ws2 = Sheets(2): Ws2.Cells.Clear
Ws1.Range("Tableau1[#All]").Copy Ws2.[A6]
With Ws2.ListObjects(1)
    .Name = "List": .TableStyle = "TableStyleMedium1"
    .Range.AutoFilter 25, "="
    With .DataBodyRange
        Set Suppr = .SpecialCells(xlCellTypeVisible)
        .AutoFilter
    End With
End With
Suppr.Delete: Ws2.Columns("C:Y").Delete
Ws2.Range("A1:A3") = Application.Transpose(Array(Ws1.[A1] & Chr(32) & Ws1.[B1], Ws1.[A2] & Chr(32) & Ws1.[B2], Ws1.[A3] & Chr(32) & Ws1.[B3]))
Ws2.Columns("A:B").AutoFit
End Sub