Macro sortant une liste selon critère

Bonjour à tous,

J'ai un fichier qui comprend :

en colonne B : Des numéros de Projets

en colonne L O Q S U et Y : Des dates importantes pour le projet.

Il me faudrait une macro qui sorte les numéros de projet des projets dont les dates vont venir au cours des 2 prochains mois

(Voir fichier pour compréhension de l'exemple)

Ex : Si nous sommes en Septembre 2011 alors la macro doit sortir les numéros de fichiers qui ont des dates en Septembre et Octobre soit : 1605, 1622, 1654, 1699

En gros, si les dates sont dans comprises entre aujourdhui et les 2 mois à venir, alors ça sort le numéro du projet.

Je ne sais pas si c'est très claire /:

Merci en tout cas !

Alexis

Bonjour,

Je n'ai pas encore regardé ton fichier mais essaye de rajouter une colonne qui calcul la différence entre la date d'aujourd'hui (DateValue(Now)) et la date prévue du projet.

Tu peux ensuite, avec une structure Si/If, soit toutes les afficher et faire un tri, soit n'afficher que celle inférieure à 2 mois et pourquoi pas faire un filtre dans ce cas.

En espérant avoir résolu le problème

En faite, c'est pour justement éviter à la hierarchie de faire toutes ses manips =/ donc c'est sans doute plus rapide par une macro.

Essaye ça :

Sub filtre()
    Dim i, j As Single
    Dim difdate As Integer
    Dim balise As Boolean

    'On se place dans la ligne d'un projet
    For i = 1 To Cells(1, 2).End(xlDown).Row
        balise = False
        'On regarde les colonnes L à Y
        For j = 12 To 25
            'Si la cellule contien une date on calcul la différence avec aujourd'hui
            If IsDate(Cells(i, j)) Then
                difdate = CDate(Cells(i, j)) - DateValue(Now) 'Renvoie un nombre de jour
                If difdate <= 60 Then
                    balise = True 'La balise indique que le projet contien une date pour les deux mois à venir
                    Exit For
                End If
            End If
        Next j
        If balise = False Then
            Rows(i).Hidden = True 'Pas de date dans les 2 mois => on masque la ligne
        End If
    Next i
        

J'espère que c'est bon, ça te masque toute les lignes qui ne te servent pas, si tu ne comprends pas tout le code demande moi.

Réponses rapides, macro qui fonctionne, que demander de plus !

Merci Quickness ; )

Bonjour à tous,

Autre façon,

il s'agit d'un exercice de filtre

ici, on ne boucle que 6 fois (sur colonnes L,O,Q,S,U,Y demandées)

Résultats sur feuille "Extrait"

Sub filtre()
Dim Lg&                                         'dernière ligne du tableau
Dim Plg As Range                                'plage visible après filtrage
Dim cL%                                         'colonne filtrée
Dim f As Worksheet
    Application.ScreenUpdating = False
    Set f = Sheets("Extrait")
    f.Range("c2:c" & f.[c65000].End(xlUp).Row + 1).EntireRow.Delete 'efface

    With Sheets("Project List")
        Lg = .Range("b" & Rows.Count).End(xlUp).Row

        '--- filtre colonnes L,O,Q,S,U,Y ---
        For cL = 12 To 25 Step 2
            '--- critères de filtre ---
            .Range("ao2") = "=AND(" & .Cells(2, cL).Address(RowAbsolute:=False) & ">TODAY()," & _
            .Cells(2, cL).Address(RowAbsolute:=False) & "<TODAY()+60)"
            '---
            .Range("a1:aL" & Lg).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
            .Range("ao1:ao2"), Unique:=False
            '---
            On Error Resume Next
                Set Plg = .Range("a2:aL" & Lg + 1).SpecialCells(xlCellTypeVisible)
            If Application.CountA(Plg) > 0 Then     'si il y a extraction
                f.Range("a" & f.[c65000].End(xlUp).Row + 1) = .Cells(1, cL)
                Plg.Copy Destination:=f.Range("b" & f.[c65000].End(xlUp).Row + 1) '(2)
            End If

            .ShowAllData: On Error GoTo 0
            '--- comme le pas n'est pas régulier, on ajuste ---
            If cL + 2 = 14 Then cL = 13             'prochaine colonne passe de 14 à 15
            'If cL + 2 = 23 Then cL = 23             'prochaine colonne passe de 23 à 25
            '---
        Next cL
            f.Range("c65000").End(xlUp)(2).EntireRow.Delete
            .Range("ao2").ClearContents
    End With
End Sub

Amicalement

Claude