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

 

[alias_2003]

Re,

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

... Désolé, je ne suis pas réveillé... La réponse est avec les en-têtes !!

J'ai testé le dernier et c'est parfait : l'exécution est instantanée !!

Question subsidiaire : j'aimerais copier cette feuille Ws2 dans un nouveau classeur et sauvegarder ce classeur sur le bureau, pourrais-tu encore m'aider ?

Merci beaucoup

 

[Si...]

salut


St Aple, es-tu devenu un vrai adepte du Tableau (d’honneurs, pas de réclamations) ?

Si non, le fichier joint montre une des syntaxes simplifiée.
Nota : il faut au moins le nom donc formulaire non modal si on a oublié de le donner

 

[Staple1600]

Re, Bonjour Si...

St Aple, es-tu devenu un vrai adepte du Tableau (d’honneurs, pas de réclamations) ?

Je suis devenu qui je suis, comme disait ce vieux Friedrich Wilhelm N.
Enfin, si j'étais moi

Si...
J'ai été lire ta conSi...Si...on trop tard
Car j'en étais rendu là

Sub d()
Dim Ws1 As Worksheet, Ws2 As Worksheet, Suppr As Range, Dligne&, t
Set Ws1 = Sheets(1): Set Ws2 = Sheets(2): Ws2.Cells.Clear
t = Array(Ws1.[A1] & Chr(32) & Ws1.[B1], Ws1.[A2] & Chr(32) & Ws1.[B2], Ws1.[A3] & Chr(32) & Ws1.[B3])
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(t)
Dligne = Ws2.Cells(Rows.Count, 1).End(3)(3).Row
Ws2.Cells(Dligne, 1).Resize(3) = Application.Transpose(t)
Ws2.Columns("A:B").AutoFit
End Sub

NB: St Aple: l'espace est volontaire, tu veux sanctifier ma pomme?
(moi qui abhorre tout sentiment religieux, sauf s'il concerne les fromages au lait cru ou l'andouillette en autres divinités)

 

[Si...]

Re

Hé St Aple, l’espace d’un jeu de mot te met dans de saintes fureurs ?

Confidence pour confidence, je suis pour la disparition de toutes les croyances religieuses ! Mon Dieu, quel impie suis-je ! Il te faudra peut-être chausser (pas aux Moines) tes lunettes comme moi pour lire ce genre de phrase !

Alias_Nad, c'est toujours le même projet ?

 

[alias_2003]

Re-,
J'ai testé vos différentes solutions proposées : MERCI à vous 2 : vos propositions sont excellentes et me conviennent parfaitement ! Merci encore !

Question subsidiaire : j'aimerais copier cette feuille Ws2 dans un nouveau classeur et sauvegarder ce classeur sur le bureau, pourrais-tu encore m'aider ?

J'aimerais ajouter un bouton "Enregistrer" sur mon userform1, pouvez-vous m'aider à finaliser ce projet ?

Alias_Nad, c'est toujours le même projet ?

Non ! Un petit projet parallèle... Je te réponds rapidement, je n'ai pas encore tout décortiqué...