Creer un filtre du VBA

Question

Je fait appel a votre expertise en Excel pour résoudre mon problème . J'ai un tableau qui se compose des données + numéro de semaine + mois + année, je voudrais a l'aide d'une macro de reporter sur une autre feuille que les données qui correspond a un numéro de semaine saisie sur une cellule ou numéro de mois, par exemple sur la feuille 2 je met semaine : 25 et Mois :6 , j'aurais que les données qui correspond a cette semaine et si je met que le mois : 6 et je met rien en numéro de semaine , j'aurai toute les données du mois : 6 J'ai mis un exemple Excel en PJ , je reste a votre dispo pour des infos complémentaires . un grand merci pour votre aide...

GGautier · Answer

Bonjour :)

Voici une solution :

Sub ExtractionPerso()
Dim BD As Worksheet, EXT As Worksheet
Dim CRIT_1 As Integer, CRIT_2 As Integer, CRIT_3 As Integer
Dim CRIT_1Bis As Integer, CRIT_2Bis As Integer, CRIT_3Bis As Integer
Dim PremLig As Integer, PremLigBis, DernLig As Integer, DernLigBis
Dim ColAnnee As Integer, ColMois As Integer, ColSem As Integer

Set BD = ThisWorkbook.Worksheets("Source")
Set EXT = ThisWorkbook.Worksheets("Resultat")
PremLig = 7
DernLig = BD.Range("A" & BD.Rows.Count).End(xlUp).Row
ColAnnee = 7
ColMois = 6
ColSem = 5

If EXT.Range("D4") = "" Then MsgBox "Merci de choisir un numéro de semaine.", vbExclamation, "Numéro de semaine": Exit Sub
If Not IsNumeric(EXT.Range("D4")) Then MsgBox "Merci de saisir un numéro de semaine valide.", vbExclamation, "Numéro de semaine": Exit Sub
CRIT_3 = EXT.Range("D4")
If CRIT_3 < 1 Or CRIT_3 > 52 Then MsgBox "Merci de saisir un numéro de semaine compris entre 1 et 52.", vbExclamation, "Numéro de semaine": Exit Sub

If EXT.Range("G4") = "" Then MsgBox "Merci de choisir un numéro de mois.", vbExclamation, "Numéro de semaine": Exit Sub
If Not IsNumeric(EXT.Range("G4")) Then MsgBox "Merci de saisir un numéro de mois valide.", vbExclamation, "Numéro de semaine": Exit Sub
CRIT_2 = EXT.Range("G4")
If CRIT_2 < 1 Or CRIT_2 > 12 Then MsgBox "Merci de saisir un numéro de mois compris entre 1 et 12.", vbExclamation, "Numéro de semaine": Exit Sub

If EXT.Range("J4") = "" Then MsgBox "Merci de choisir une année.", vbExclamation, "Numéro de semaine": Exit Sub
If Not IsNumeric(EXT.Range("J4")) Then MsgBox "Merci de saisir une année valide.", vbExclamation, "Numéro de semaine": Exit Sub
CRIT_1 = EXT.Range("J4")
If CRIT_1 < 1900 Or CRIT_1 > 9999 Then MsgBox "Merci de saisir une année compris entre 1900 et 9999.", vbExclamation, "Numéro de semaine": Exit Sub

PremLigBis = 8
DernLigBis = EXT.Range("A" & EXT.Rows.Count).End(xlUp).Row
If DernLigBis > PremLigBis Then EXT.Range("A" & PremLigBis & ":G" & DernLigBis).Clear

On Error Resume Next
For i = PremLig To DernLig
    CRIT_1Bis = BD.Cells(i, ColAnnee)
    CRIT_2Bis = BD.Cells(i, ColMois)
    CRIT_3Bis = BD.Cells(i, ColSem)
    If CRIT_1 = CRIT_1Bis Then
        If CRIT_2 = CRIT_2Bis Then
            If CRIT_3 = CRIT_3Bis Then
                DernLigBis = EXT.Range("A" & EXT.Rows.Count).End(xlUp).Row + 1
                EXT.Cells(DernLigBis, 1) = BD.Cells(i, 1)
                EXT.Cells(DernLigBis, 2) = BD.Cells(i, 2): EXT.Cells(DernLigBis, 2).NumberFormat = "m/d/yyyy"
                EXT.Cells(DernLigBis, 3) = BD.Cells(i, 3)
                EXT.Cells(DernLigBis, 4) = BD.Cells(i, 4)
                EXT.Cells(DernLigBis, 5) = BD.Cells(i, 5)
                EXT.Cells(DernLigBis, 6) = BD.Cells(i, 6)
                EXT.Cells(DernLigBis, 7) = BD.Cells(i, 7)
            End If
        End If
    End If
Next i
End Sub