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