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

warrio

XLDnaute Nouveau
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
Code:
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
 

Pièces jointes

  • fichier test.xlsm
    77 KB · Affichages: 37

Lolote83

XLDnaute Barbatruc
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
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 912
Membres
101 837
dernier inscrit
Ugo