XL 2010 Aide optimisation + complément code

[safranien]

Bonjour

j'ai glané ici et là pour essayer de trouver des codes de macro pour réussir à réaliser ce que je cherche à faire et j'ai réussi en partie.
Pour la partie de code que j'ai écrite je suis persuadé que c'est très "moche" et que pour le pros ça piquera les yeux d'où ma demande pour essayer d'écrire ça proprement.
En complément, je voudrais ajouter dans cette macro un code pour supprimer le filtre en place de ma feuille puis, à la fin de l'exécution du code, que le filtre se remette en place en un filtre actif.

Plus de détails:
_ un onglet "LISTE" qui est ma base de données complète
_ un onglet "Annex 3b" dans lequel je ne reprends que quelques valeurs de l'onglet LISTE
Ce dernier est mis en forme avec des titres de colonnes (qui ne changeront pas), mise en page de la feuille, cellules centrées haut/bas etc, de la ligne 1 à 500.
Je garnirai/modifierai mon onglet LISTE de données plusieurs fois dans l'année et je veux pouvoir éditer une synthèse via l'onglet Annexe 3b avec la recopie des données dans le même ordre que LISTE. Via ma macro je fais donc une recopie de valeur. Mon filtre s'étend sur les cellules A5:O5.

Au lancement de la macro, j'aimerais donc:
_ enlever le filtre
_ supprime toutes les données des colonnes A et B et de D à O (je ne veux pas effacer la colonne C qui a des données fixes), de la ligne 6 jusque totalement au bas de la feuille (on ne sait jamais si un jour je dépasse les 500 lignes)
_ réactiver le filtre sur les cellules A5:O5
_ filtrer la colonne G sur les cellules non vides

J'espère que vous pourrez m'aider.

Sub Annexe_3b()
Dim NbrLignes As Long, CptLignes As Long
With Sheets("Annexe 3b")
' Effacer
NbrLignes = Sheets("LISTE").Range("E65526").End(xlUp).Row ---> j'ai mis E mais je ne sais pas ce que ça change si je mets une autre lettre
Sheets("Annexe 3b").Range("A6:B" & NbrLignes).ClearContents
Sheets("Annexe 3b").Range("D6:O" & NbrLignes).ClearContents

'Copie des colonnes de la source
NbrLignes = Sheets("LISTE").Range("E65526").End(xlUp).Row ---> j'ai mis E mais je ne sais pas ce que ça change si je mets une autre lettre

Sheets("LISTE").Range("E2:E" & NbrLignes).Copy
.Range("A6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("B2:B" & NbrLignes).Copy
.Range("B6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("H2:H" & NbrLignes).Copy
.Range("D6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("AA2:AA" & NbrLignes).Copy
.Range("E6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("AE2:AE" & NbrLignes).Copy
.Range("F6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("F2:F" & NbrLignes).Copy
.Range("G6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("X2:X" & NbrLignes).Copy
.Range("H6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("CX2:CX" & NbrLignes).Copy
.Range("I6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("Y2:Y" & NbrLignes).Copy
.Range("J6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("DS2S" & NbrLignes).Copy
.Range("K6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("AO2:AO" & NbrLignes).Copy
.Range("N6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Sheets("LISTE").Range("AW2:AW" & NbrLignes).Copy
.Range("O6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

End With


End Sub

 

[safranien]

Bonjour
une p'tit coup de pouce svp...?

 

[cathodique]

Bonjour,

Un petit fichier Safranien

 

[safranien]

Bonjour Cathodique

ci-joint

 

[cathodique]

Voici ton code "débroussaillé".

Sub Annexe_3b()

    Dim NbrLignes As Long, CptLignes As Long
    Dim Fl As Worksheet, Fa As Worksheet
    Set Fl = Worksheets("liste")
    Set Fa = Worksheets("Annexe 3b")

    With Fa
        ' Effacer
        .Range("A6:B505").ClearContents
        .Range("D6:O505").ClearContents

        NbrLignes = Fl.Cells(Rows.Count, 5).End(xlUp).Row
        'Copie des colonnes de la source
        Fl.Range("E2:E" & NbrLignes).Copy .Range("A6")    '
        Fl.Range("B2:B" & NbrLignes).Copy .Range("B6")
        Fl.Range("H2:H" & NbrLignes).Copy .Range("D6")
        Fl.Range("AA2:AA" & NbrLignes).Copy .Range("E6")
        Fl.Range("AE2:AE" & NbrLignes).Copy .Range("F6")
        Fl.Range("F2:F" & NbrLignes).Copy .Range("G6")
        Fl.Range("X2:X" & NbrLignes).Copy .Range("H6")
        Fl.Range("CX2:CX" & NbrLignes).Copy .Range("I6")
        Fl.Range("Y2:Y" & NbrLignes).Copy .Range("J6")
        Fl.Range("DS2:DS" & NbrLignes).Copy .Range("K6")
        Fl.Range("AO2:AO" & NbrLignes).Copy .Range("N6")
        Fl.Range("AW2:AW" & NbrLignes).Copy .Range("O6")
        Application.CutCopyMode = False
    End With
End Sub
Sub Effacer()
    Dim NbrLignes As Long, CptLignes As Long
    NbrLignes = Fl.Cells(Rows.Count, 5).End(xlUp).Row
    With Sheets("Annexe 3b")
        ' Effacer
        .Range("A6:B" & NbrLignes).ClearContents
        .Range("D6:O" & NbrLignes).ClearContents
        .Range("A6").Select
    End With
End Sub

Très souvent, il vaut mieux expliquer ce que l'on souhaite comme résultat final que de demander ce qu'on veut faire.