XL 2010 [VBA] Filtre et extraction données [RESOLU]

[warrio]

Bonjour,

je vous sollicite afin d'optimiser une macro que j'ai réalisée.
Je dispose d'un fichier alimenté par différentes personnes, dans l'onglet "BD"
le but étant de faire un filtre mensuel (1 a 12 colonne "AK") et extraire une partie des données visible après filtrage (toujours les mêmes plage (colonne B a G) + Y + (colonne AC a AE) + AH et AI )
et les copier dans les onglets correspondant pour mettre à jour le fichier.
si je pouvais avoir une mise en forme standard avec bordure ce serais un plus.

je vous joins un fichier dans laquelle la macro est dans le module

j'ai essayé de passer par un tableau pour accélérer le traitement mais mes compétences sont limitées en VBA.
merci pour votre aide.
cordialement

Option Explicit

Dim f, i, ln, lgn, mois, mafeuille


Sub trimensuel()

'applique filtre mensuel

    Application.ScreenUpdating = False
    Sheets("BD").Activate
   
    'boucle sur 12 mois
    For mois = 1 To 12
    
       Select Case mois
      Case 1
        mafeuille = "Janvier"
      Case 2
        mafeuille = "Février"
      Case 3
       mafeuille = "Mars"
      Case 4
       mafeuille = "Avril"
      Case 5
        mafeuille = "Mai"
      Case 6
        mafeuille = "Juin"
         Case 7
        mafeuille = "Juillet"
         Case 8
        mafeuille = "Aout"
         Case 9
       mafeuille = "Septembre"
         Case 10
        mafeuille = "Octobre"
         Case 11
        mafeuille = "Novembre"
         Case 12
        mafeuille = "Décembre"
       
    End Select
  
     
   
    '---
    Set f = Sheets("BD")
    f.Range("A5:BC" & f.Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1
    f.Range("A5:BC" & f.Range("A" & Rows.Count).End(xlUp).Row).Sort _
                key1:=Range("AI5"), order1:=xlAscending, _
                key2:=Range("B5"), order1:=xlAscending, _
                Header:=xlGuess
    f.Range("A5:BC" & f.Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=37, Criteria1:=mois 'tri par mois
   
   
       Sheets(mafeuille).Range("A2:L" & Sheets(mafeuille).Range("A" & Rows.Count).End(xlUp)(2).Row).ClearContents
   
    i = 0
           lgn = Sheets(mafeuille).Range("A" & Rows.Count).End(xlUp).Row
          
          
    For ln = 6 To f.Range("A" & Rows.Count).End(xlUp).Row
       
        If f.Rows(ln & ":" & ln).EntireRow.Hidden = False Then
            i = i + 1
            lgn = lgn + 1
         
         
              f.Range("B" & ln).Copy: Sheets(mafeuille).Range("A" & lgn).PasteSpecial xlPasteValues
            f.Range("C" & ln).Copy: Sheets(mafeuille).Range("B" & lgn).PasteSpecial xlPasteValues
            f.Range("D" & ln).Copy: Sheets(mafeuille).Range("C" & lgn).PasteSpecial xlPasteValues
            f.Range("E" & ln).Copy: Sheets(mafeuille).Range("D" & lgn).PasteSpecial xlPasteValues
            f.Range("F" & ln).Copy: Sheets(mafeuille).Range("E" & lgn).PasteSpecial xlPasteValues
            f.Range("G" & ln).Copy: Sheets(mafeuille).Range("F" & lgn).PasteSpecial xlPasteValues
            f.Range("Y" & ln).Copy: Sheets(mafeuille).Range("G" & lgn).PasteSpecial xlPasteValues
            f.Range("AC" & ln).Copy: Sheets(mafeuille).Range("H" & lgn).PasteSpecial xlPasteValues
            f.Range("AD" & ln).Copy: Sheets(mafeuille).Range("I" & lgn).PasteSpecial xlPasteValues
            f.Range("AE" & ln).Copy: Sheets(mafeuille).Range("J" & lgn).PasteSpecial xlPasteValues
            f.Range("AH" & ln).Copy: Sheets(mafeuille).Range("K" & lgn).PasteSpecial xlPasteValues
            f.Range("AI" & ln).Copy: Sheets(mafeuille).Range("L" & lgn).PasteSpecial xlPasteValues
         
            If i = 20 Then Exit For
        End If
    Next ln
    '-----
    
    
     'fin boucle mois
     Next mois
   
   
    
     '-------
   
 
    f.Range("A5:BC" & f.Range("A" & Rows.Count).End(xlUp).Row).AutoFilter 'Field:=1
    f.Range("A5:BC" & f.Range("A" & Rows.Count).End(xlUp).Row).Sort _
                key2:=Range("AI5"), order1:=xlAscending, _
                key1:=Range("B5"), order1:=xlAscending, _
                Header:=xlGuess
   f.Range("A5:BC5").AutoFilter
   
    MsgBox "Travail terminé"
            
 
    Sheets("BD").Select
   
End Sub

 

[Lolote83]

Salut Warrio,
Quel est le critère pour affecter ton listing (BD) sur Janvier, février, mars .....
Je pensais à une date mais je n'ai pas trouvé sur quelle colonne il faut intervenir
Merci de me dire
@+ Lolote83

 

[kingfadhel]

Bonsoir, le forum, le fil

à toi @warrio.
Solution avec :

• réduction du nombre de lignes de code
• mise en forme,
• bordure,
• nombre de lignes copiées
• temps d'exécution.

 

[warrio]

Salut Warrio,
Quel est le critère pour affecter ton listing (BD) sur Janvier, février, mars .....
Je pensais à une date mais je n'ai pas trouvé sur quelle colonne il faut intervenir
Merci de me dire
@+ Lolote83

la colonne "AK" représente les mois de 1 a 12 (1 pour janvier 12 pour decembre)

 

[Lolote83]

Salut WARRIO, KINGFADHEL,
Sans avoir regardé le fichier de KingFadhel, voici ma contribution, basée sur les filtres élaborés
@+ Lolote83

 

[warrio]

merci pour votre aide,
les 2 solutions fonctionnent parfaitement.
cordialement

 

[cathodique]

merci pour votre aide,
les 2 solutions fonctionnent parfaitement.

@warrio: 😉, désolé de mettre mon grain de sel, mais il me semble que la solution basée sur les filtres élaborés ne donne pas les résultats escomptés, à toi de voir c'est ton fichier.

bonne continuation.

 

[Lolote83]

Salut à tous,

@warrio: 😉, désolé de mettre mon grain de sel, mais il me semble que la solution basée sur les filtres élaborés ne donne pas les résultats escomptés, à toi de voir c'est ton fichier.
bonne continuation.

En quoi la solution proposée via les filtres élaborées n'est pas conforme à la demande ?
Ai-je oublié quelques choses ?
Cordialement
Lolote83